c irifun.for, version number can be found at the end of this comment.
c-----------------------------------------------------------------------
C Functions and subroutines for the International Reference Ionosphere 
C (IRI) model. These functions and subroutines are called by the main
C IRI subroutine IRI_SUB in IRISUB.FOR.
c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c Required i/o units:  
c  KONSOL= 6 Program messages (used when jf(12)=.true. -> konsol)
c  KONSOL=11 Program messages (used when jf(12)=.false. -> MESSAGES.TXT)
c
c     COMMON/iounit/konsol,mess is used to pass the value of KONSOL from 
c     IRISUB to IRIFUN and IGRF. If mess=false then messages are turned off.
c     
c  UNIT=12 TCON: Solar/ionospheric indices IG12, R12 (IG_RZ.DAT) 
c  UNIT=13 APF,APFMSIS,APF_ONLY: Magnetic indices and F10.7 (APF107.DAT) 
c
c I/o Units used in other programs:
c  IUCCIR=10 in IRISUB for CCIR and URSI coefficients (CCIR%%.ASC, %%=month+10)
c  UNIT=14 in IGRF/GETSHC for IGRF coeff. (DGRF%%%%.DAT, %%%%=year)
c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c changes from IRIFU9 to IRIF10:
c       SOCO for solar zenith angle 
c       ACOS and ASIN argument forced to be within -1 / +1
c       EPSTEIN functions corrected for large arguments
c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c changes from IRIF10 to IRIF11: 
c       LAY subroutines introduced
c       TEBA corrected for 1400 km
c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c changes from IRIF11 to IRIF12:
C       Neutral temperature subroutines now in CIRA86.FOR 
C       TEDER changed
C       All names with 6 or more characters replaced 
C       10/29/91 XEN: 10^ in loop, instead of at the end
C       1/21/93 B0_TAB instead of B0POL
C       9/22/94 Alleviate underflow condition in IONCOM exp()
c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c changes from IRIF12 to IRIF13:
C        9/18/95 MODA: add leap year and number of days in month
C        9/29/95 replace F2out with FOUT and XMOUT.
C       10/ 5/95 add TN and DTNDH; earlier in CIRA86.FOR
C       10/ 6/95 add TCON for reading indices
C       10/20/95 MODA: IN=1 MONTH=IMO
C       10/20/95 TCON: now includes RZ interpolation
C       11/05/95 IONCOM->IONCO1, added IONCOM_new, IONCO2
C       11/05/95 LSTID added for strom-time updating
C       11/06/95 ROGUL: transition 20. instead of 15.
C       12/01/95 add UT_LT for (date-)correct UT<->LT conversion
C       01/16/96 TCON: add IMST to SAVE statement
C       02/02/96 ROGUL: 15. reinstated
C       02/07/96 UT_LT: ddd, dddend integer, no leap year 2000
C       03/15/96 ZERO: finding delta for topside
C       03/18/96 UT_LT: mode=1, change of year
C       12/09/96 since 2000 is leap, delete y/100*100 condition
C       04/25/97 XMDED: minimal value also daytime
C       05/18/98 TCON: changes to IG_RZ (update date); -R = Cov
C       05/19/98 Replaced IONCO2&APROK; HEI,XHI in IONCOM_NEW
C       10/01/98 added INITIALIZE
C       04/30/99 MODA: reset bb(2)=28
C       11/08/99 avoid negative x value in function XE2. Set x=0.
C       11/09/99 added COMMON/const1/humr,dumr also for CIRA86
C       11/30/99 EXIT in APROK replaced with GOTO (N. Smirnova)
c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c changes from IRIF13 to IRIFUN:
C-Version-mm/dd/yy-description [person reporting correction]
C 2000.01 05/09/00 Include B0_98 subroutine to replace B0_NEW and B0POL
C 2000.02 05/18/00 Include Elteik and spharm_ik for Te
C 2000.03 06/09/00 Include xe3_1, xe4_1, xe_1
C 2000.04 06/11/00 Include f1_c1, f1_prob, modified fof1ed
C 2000.05 10/30/00 Include vdrift
C 2000.06 04/15/01 Include IGRF_SUB subroutine for IK Te model
C 2000.07 05/07/01 Include storm subroutine STORM and Ap access s/w
C 2000.08 09/07/01 APF: if(j1.eq.j2) -> if(IY.eq.j2) [P. Wilkinson]
C 2000.09 09/07/01 CONVER: LO2 = MOD(LO1,20)+1 [P. Webb,D. Pesnell]
C 2000.10 02/20/02 CONVER/DATA: 105.78 -> 015.78 [A. Shovkoplyas] 
C 2000.11 10/28/02 replace TAB/6 blanks, enforce 72/line [D. Simpson]
C 2000.12 11/08/02 removing unused variables (corr); apf0 removed
C 2000.13 11/26/02 apf() using keyed access to ap.dat file; apf->apf1
C 2000.14 11/27/02 changed F1_PROB; always 6 preceeding spaces 
C 2005.01 03/09/05 CALION,INVDPC,CALNE for new Ne, Ni models
C 2005.01 11/14/05 APF_ONLY for F107D;  
C 2005.01 11/14/05 spreadf_brazil; added constraint 0<=P<=1 
C 2005.02 05/11/06 NeQuick: XE1,TOPQ, M3000HM; stormvd,
C 2005.02 03/27/07 STORM: hourly interpolation of Ap  [A. Oinats]
C 2007.00 05/18/07 Release of IRI-2007
C 2007.01 09/19/07 vdrift et al.: without *8 (no change in results)
C 2007.04 02/07/09 IONLOW: N+ correction [V. Truhlik]
C 2007.05 03/30/09 NMDED: avoid exp underflow [K. Choi] 
C 2007.05 03/30/09 spreadf_brazil: bspl2f et al b(20->30) [Tab Ji]
C 2007.05 03/30/09 APF_ONLY: Compute monthly F10.7
C 2007.06 05/26/09 APF_ONLY: replace i with 1 and IMN with ID [R.Conde]
C 2007.07 07/10/09 CONVER/DATA: 015.78 -> 005.78 [E. Araujo] 
C 2007.08 07/23/09 STORM/CONVER: long. discont. [R. Conde, E. Araujo] 
C 2007.08 07/23/09 APF,APF_ONLY: use YearBegin from ap.dat [R. Conde] 
C 2007.10 02/03/10 APF: eof error message; clean-up APF and APF_only
C 2007.11 04/19/10 ELTEIK:     IF (ALT .GE. 900) THEN      [A. Senior]
C 2007.11 04/19/10 INILAY: HFFF,XFFF when NIGHT=F1REG=f    [A. Senior]
C
C 2012.00 10/05/11 IRI-2012: bottomside B0 B1 model (SHAMDB0D, SHAB1D),
C 2012.00 10/05/11   bottomside Ni model (iriflip.for), auroral foE
C 2012.00 10/05/11   storm model (storme_ap), Te with PF10.7 (elteik),
C 2012.00 10/05/11   oval kp model (auroral_boundary),IGRF-11(igrf.for), 
C 2012.00 10/05/11   NRLMSIS00 (cira.for), CGM coordinates, F10.7 daily
C 2012.00 10/05/11   81-day 365-day indices (apf107.dat), ap->kp (ckp),
C 2012.00 10/05/11   array size change jf(50) outf(20,1000), oarr(100).
C 2012.00 10/05/11   No longer needed: TEDER,DTNDH
C 2012.01 11/08/11 SHAMDB0D+: Initialize COMMON variables outside DATA
C 2012.01 11/08/11 SCHNEVPD,LEGFUN: COSD(x) -> COS(x*UMR)
C 2012.01 11/08/11 auroral_boundary: i1.gt/ge.48
C 2012.01 11/08/11 CALION: F107D upper/lower boundary 220/65
C 2012.01 01/06/12 delete PAUSE statement in SPLINT
C 2012.01 01/24/12 STORME_AP: change 365 to 366 leap year    [F. Simoes]
C 2012.01 06/30/12 HMF2ED: hmF2 too low foF2/foE ge 1.7 [I.Zakharenkova]
C 2012.01 09/14/12 SHAMDB0D,SHAB1D: initializing CONS2      [P. Coisson]
C 2012.02 12/12/12 STORME_AP: add KONSOL and ERROR ouput STORME_AP=-5.
C 2012.03 01/22/14 TPCORR: INVDIP --> INVDP                [J.K. Knight]
C 2012.04 07/24/14 COMMON/iounit/ added 'mess'
C 2012.05 08/25/14 ELTEIK,INVDPC,SOCO: ACOS: if(abs(x).gt.1) x=sign(1,x)
C 2012.06 10/02/14 IONLOW,IONHIGH: C1(82) added for SPHARM_IK [J.C. Xue]
C 2012.07 12/22/14 APFMSIS: changed text if out of range of APF107.DAT
C 2012.08 04/27/15 TCON: ionoindx(806),indrz(806)
C 2012.09 07/12/15 add read_ig_rz, readapf107 change TCON,APF* 
C 2012.10 07/20/15 APFMSIS: remove duplicate iiap(8)         [E. Blanch]
C 2012.11 04/11/18 read_ig_rz: rz=rz_new*0.7 from 01/2014, ig_rz_10_2016
C 2012.12 04/16/18 Versioning now based on year of major releases
C                  
c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c IRI functions and subroutines:
C Ne:       XE1,TOPQ,ZERO,DXE1N,XE2,XE3_1,XE4_1,XE5,XE6,XE_1
C Te, Ti:   ELTEIK{INTERP,KODERR,KOEFD,KOF107,LOCATE,SPHARM_IK, 
C		    SPLINE,SPLINT,SWAPEL,TEDIFI,TPCAS,TPCORR},TEBA,SPHARM,
C           ELTE,TEDE,TI,TN
C Ni:       RPID,RDHHE,RDNO,KOEFP1,KOEFP2,KOEFP3,SUFE,IONDANI,IONCO1, 
C           IONCO2,APROK,CALION,IONLOW,IONHIGH,INVDPC
C PEAKS:    FOUT,XMOUT,HMF2ED,FOF1ED,f1_c1,f1_prob,FOEEDI,XMDED,GAMMA1
C PROFILE:  TOPH05, CHEBISH, SHAMDB0D, SHAB1D, SCHNEVPD, TBFIT,  
C           LEGFUN,B0_98,TAL,VALGUL, DREGION
C MAG. FIELD: FIELDG, CONVER(Geom. Corrected Latitude)
C TIME:     SOCO,HPOL,MODA,UT_LT,CLCMLT,SUN
C EPSTEIN:  RLAY,D1LAY,D2LAY,EPTR,EPST,EPSTEP,EPLA
C LAY:      XE2TO5,XEN,ROGUL,LNGLSN,LSKNM,INILAY
C INDICES:  TCON,APF,APFMSIS,APF_ONLY
C STORM:   	CONVER, STORM, STORME_AP
C Vi:       vdrift,bspl4_time,bspl4_long,g,stormvd,bspl4_ptime
C Spread-F:	spreadf_brazil,bspl2f,bspl2l,bspl2s,bspl4t
C Auroral: 	auroral_boundary, ckp
C Misc:     REGFA1
c-----------------------------------------------------------------------
C
C        
C*************************************************************   
C*************** ELECTRON DENSITY ****************************   
C*************************************************************   
C

        FUNCTION XE1(H)    
c----------------------------------------------------------------
C DETERMINING ELECTRON DENSITY(M-3) IN THE TOPSIDE IONOSPHERE   
C (H=HMF2....2000 KM) BY HARMONIZED BENT-MODEL ADMITTING 
C VARIABILITY OF THE GLOBAL PARAMETERS BETA,ETA,DELTA,ZETA WITH        
C GEOM. LATITUDE, SMOOTHED SOLAR FLUX AND CRITICAL FREQUENCY.     
C BETA,ETA,DELTA,ZETA are computed in IRISUB program and 
C communicated via COMMON /BLO10. This is the IRI-2001 approach
C [REF.:K.RAWER,S.RAMAKRISHNAN,1978] 
C New options include:
C (1) IRI-corrected: TC3,alg10,hcor1 in COMMON /BLO11. 
C   TC3     correction term divided by (1500-(hcor1-hmF2))
C   alg10   = alog(10.)
C	hcor1	lower height boundary for correction
C (2) NeQuick:  B2TOP  in COMMON /BLO11.
C	B2TOP   is the topside scale height that depends on foF2 and 
C           hmF2. 
C Switch for choosing the desired option is itopn in COMMON /BLO11
C   itopn   =0 IRI-2001, =1 IRI-2001-corrected, =2 NeQuick
C           =3 Gulyaeva-0.5 is not yet implemented. 
c----------------------------------------------------------------
        COMMON  /BLOCK1/HMF2,XNMF2,HMF1,F1REG
     &          /BLO10/BETA,ETA,DELTA,ZETA
     &          /BLO11/B2TOP,TC3,itopn,alg10,hcor1
     &          /QTOP/Y05,H05TOP,QF,XNETOP,xm3000,hhalf,tau
     &          /ARGEXP/ARGMAX

        logical 	f1reg              

        IF(itopn.eq.2) THEN
          XE1=TOPQ(H,XNMF2,HMF2,B2TOP)
          RETURN
        ENDIF
      
        DXDH = (1000.-HMF2)/700.
        x0 = 300. - delta
        xmx0 = (H-HMF2)/DXDH
        x = xmx0 + x0
        eptr1 = eptr(x,beta,394.5) - eptr(x0,beta,394.5)
        eptr2 = eptr(x,100.,300.0) - eptr(x0,100.,300.0) 
        y = BETA * ETA * eptr1 + ZETA * (100. * eptr2 - xmx0)
        Y = y * dxdh
        if(abs(Y).gt.argmax) Y = sign(argmax,Y)

        IF(itopn.eq.3) then
	         IF((QF.EQ.1.).AND.(ABS(H-H05TOP).LT.1.)) QF=Y05/Y
             XE1 = XNMF2 * EXP(-Y*QF)                             
             RETURN          
             endif
        TCOR = 0.
        IF(itopn.eq.1.and.h.gt.hcor1) then
             xred = h - hcor1
             rco = tc3 * xred
             TCOR = rco * alg10
             endif
        XE1 = XNMF2 * EXP(-Y+TCOR)                             
        RETURN          
        END             
C
C

        REAL FUNCTION TOPQ(h,No,hmax,Ho)
c----------------------------------------------------------------
c  NeQuick formula
c----------------------------------------------------------------
        REAL No
        PARAMETER (g=0.125,rfac=100.0)
          dh=h-hmax
          g1=g*dh
          z=dh/(Ho*(1.0+rfac*g1/(rfac*Ho+g1)))
          if(z.gt.40) then
            topq=0.0
            return
          endif
          ee=exp(z)
          if (ee.gt.1.0e7) then
            ep=4.0/ee
          else
            ep=4.0*ee/(1.0+ee)**2
          endif
          TOPQ=No*ep
        RETURN
        END

C 
C
        REAL FUNCTION ZERO(DELTA)
C FOR A PEAK AT X0 THE FUNCTION ZERO HAS TO BE EQUAL TO 0.
        COMMON  /BLO10/         BETA,ETA,DEL,ZETA
     &          /ARGEXP/        ARGMAX

        arg1=delta/100.
        if (abs(arg1).lt.argmax) then
                z1=1./(1.+exp(arg1))
        else if (arg1.lt.0) then
                z1=1.
        else
                z1=0.
        endif
        arg1=(delta+94.5)/beta
        if (abs(arg1).lt.argmax) then
                z2=1./(1.+exp(arg1))
        else if (arg1.lt.0) then
                z2=1.
        else
                z2=0.
        endif
        zero=zeta*(1.-z1) - eta*z2
        return
        end
C
C
        FUNCTION DXE1N(H)                            
C LOGARITHMIC DERIVATIVE OF FUNCTION XE1 (KM-1).   
        COMMON    /BLOCK1/HMF2,XNMF2,HMF1,F1REG
     &            /BLO10/BETA,ETA,DELTA,ZETA                    
	    logical f1reg

        x0 = 300. - delta
        X=(H-HMF2)/(1000.0-HMF2)*700.0 + x0
        epst2 = epst(x,100.0,300.0)
        epst1 = epst(x,beta ,394.5)
        DXE1N = - ETA * epst1 + ZETA * (1. - epst2)             
        RETURN          
        END             
C
C
        REAL FUNCTION XE2(H)                         
C ELECTRON DENSITY FOR THE BOTTOMSIDE F-REGION (HMF1...HMF2).                   
        COMMON    /BLOCK1/HMF2,XNMF2,HMF1,F1REG
     &          /BLOCK2/B0,B1,C1        /ARGEXP/ARGMAX
	    logical	f1reg

        X=(HMF2-H)/B0
        if(x.le.0.0) x=0.0
        z=x**b1
        if(z.gt.argmax) z=argmax
        XE2=XNMF2*EXP(-z)/COSH(X)                 
        RETURN          
        END             
C
C
        REAL FUNCTION XE3_1(H)
C ELECTRON DENSITY FOR THE F1-LAYER (HZ.....HMF1)
C USING THE NEW DEFINED F1-LAYER FUNCTION (Reinisch and Huang, Advances 
C in Space Research, Volume 25, Number 1, 81-88, 2000)
        COMMON	/BLOCK1/	HMF2,XNMF2,HMF1,F1REG
     &		/BLOCK2/	B0,B1,D1F1
	    logical	f1reg
C
	    h1bar=h
        if (f1reg) H1BAR=HMF1*(1.0-((HMF1-H)/HMF1)**(1.0+D1F1))
        XE3_1=XE2(H1BAR)
        RETURN
        END
C
C
        REAL FUNCTION XE4_1(H)
C ELECTRON DENSITY FOR THE INTERMEDIATE REGION (HEF...HZ)
C USING THE NEW DEFINED FUNCTION
        COMMON	/BLOCK3/	HZ,T,HST
     &		/BLOCK4/	HME,XNME,HEF
C
	    if(hst.lt.0.0) then
		xe4_1=xnme+t*(h-hef)
		return
		endif
        IF(HST.EQ.HEF) THEN
           H1BAR=H
        ELSE
           H1BAR=HZ+0.5*T-SIGN(1.0,T)*SQRT(T*(0.25*T+HZ-H))
        ENDIF
        XE4_1=XE3_1(H1BAR)
        RETURN
        END
C
C
        REAL FUNCTION XE5(H)                         
C ELECTRON DENSITY FOR THE E AND VALLEY REGION (HME..HEF).   
        LOGICAL NIGHT   
        COMMON    /BLOCK4/        HME,XNME,HEF
     &          /BLOCK5/        NIGHT,E(4)                    
        T3=H-HME        
        T1=T3*T3*(E(1)+T3*(E(2)+T3*(E(3)+T3*E(4))))  
        IF(NIGHT) GOTO 100                           
        XE5=XNME*(1+T1)  
        RETURN          
100     XE5=XNME*EXP(T1)                              
        RETURN          
        END             
C
C
        REAL FUNCTION XE6(H)                         
C ELECTRON DENSITY FOR THE D REGION (HA...HME).    
        COMMON    /BLOCK4/        HME,XNME,HEF
     &          /BLOCK6/        HMD,XNMD,HDX
     &        /BLOCK7/        D1,XKK,FP30,FP3U,FP1,FP2    
        IF(H.GT.HDX) GOTO 100                        
        Z=H-HMD         
        FP3=FP3U        
        IF(Z.GT.0.0) FP3=FP30                        
        XE6=XNMD*EXP(Z*(FP1+Z*(FP2+Z*FP3)))           
        RETURN          
100     Z=HME-H         
        XE6=XNME*EXP(-D1*Z**XKK)
        RETURN          
        END             
C
C
        REAL FUNCTION XE_1(H)                          
C ELECTRON DENSITY BEETWEEN HA(KM) AND 1000 KM     
C SUMMARIZING PROCEDURES  NE1....6;                
        COMMON    /BLOCK1/HMF2,XNMF2,XHMF1,F1REG         
     &          /BLOCK3/HZ,T,HST
     &        /BLOCK4/HME,XNME,HEF
	    logical 	f1reg
	    if(f1reg) then
		   hmf1=xhmf1
	    else
		   hmf1=hmf2
	    endif
        IF(H.LT.HMF2) GOTO 100                       
        XE_1=XE1(H)     
        RETURN          

100     IF(H.LT.HMF1) GOTO 300                       
        XE_1=XE2(H)       
        RETURN          

300     IF(H.LT.HZ) GOTO 400                         
        XE_1=XE3_1(H)       
        RETURN          

400     IF(H.LT.HEF) GOTO 500                        
        XE_1=XE4_1(H)       
        RETURN          

500     IF(H.LT.HME) GOTO 600                        
        XE_1=XE5(H)       
        RETURN          

600     XE_1=XE6(H)       
        RETURN          
        END             
C
C                     
C**********************************************************                     
C***************** ELECTRON TEMPERATURE ********************                    
C**********************************************************                     
C
      SUBROUTINE ELTEIK(CRD,PF107Y,INVDIP,FL,DIMO,B0,
     &                   DIPL,MLT,ALT,DDD,PF107,TE,SIGTE)
C----------------------------------------------------------------------
C Empirical model of electron temperature (Te) in the outer ionosphere
C with inclusion of solar activity.
C Based on spherical harmonics approximation of measured
C Te (all available satellites) at altitudes centred on 350km, 550km,
C 850km, 1400km, and 2000km. For intermediate altitudes a linear
C interpolation is used. Recommended altitude range: 300-2500 km!!!
C Linear extrapolation is used for altitude ranges <300;350)km
C and (2000;2500> km. For days between seasons centred at
C (21.3. = 79; 21.6. = 171; 23.9. 265; 21.12. = 354) Te is
C interpolated by a harmonic function.
C Inputs: CRD - 0 .. INVDIP
C               1 .. FL, DIMO, B0, DIPL (used for calc. INVDIP inside)
C         PF107Y - 0 .. PF107 correction NOT included
C                  1 .. PF107 correction included
C         INVDIP - "mix" coordinate of the dip latitude and of
C                    the invariant latitude;
C                    positive northward, in deg, range <-90.0;90.0>
C         FL, DIMO, BO - McIlwain L parameter, dipole moment in
C                        Gauss, magnetic field strength in Gauss -
C                        parameters needed for invariant latitude
C                        calculation
C         DIPL - dip latitude
C                positive northward, in deg, range <-90.0;90.0>
C         MLT - magnetic local time (central dipole)
C               in hours, range <0;24)
C         ALT - altitude above the Earth's surface;
C               in km, range <500;3000>
C         DDD - day of year; range <0;365>
C         PF107 - Phil Richard's solar radio flux;
C Output: TE - electron temperature in K
C         SIGTE - standard deviation (or model error) of TE in K
C Versions: 1.00 (IDL) the first version Te=Te(invl,mlt,alt,season)
C           1.50 (IDL) corrected IK19 Te at 900km for possible Ne>2E11 m-3
C           2.00 (IDL) F107 included as a linear perturbation on global Te pattern
C                      Te=Te(invlat,mlt,alt,season,F107)
C           3.00 (IDL) invdipl introduced
C           2000 (IDL,FORTRAN) correction for seasons included
C           2010 (IDL,FORTRAN) completely new version 
C Authors of the model (v 2011)
C                V. Truhlik, D. Bilitza, and L. Triskova
C Author of the code:
C         Vladimir Truhlik
C         Institute of Atm. Phys.
C         Bocni II.
C         141 31 Praha 4, Sporilov
C         Czech Republic
C         e-mail: vtr@ufa.cas.cz
C----------------------------------------------------------------------
      REAL INVDIP,FL,DIMO,B0,DIPL,MLT,ALT,PF107,TE,SIGTE
      INTEGER CRD,PF107Y,DDD,SEZDAY,XDAY
      INTEGER MIRREQ(81)
      REAL D(5,3,81),DERRTE(5,3,81),DPF107(5,3,81)
      DOUBLE PRECISION B(8),A
      REAL DPI,DTOR,ASA,INVL,RINVL,INVDP,RDIPL,ALFA,BETA
      REAL RMLT,RCOLAT
      REAL C(82)
      INTEGER SEZA,SEZB,DDDA,DDDB,DDDD
      REAL T350,T350A,T350B,T550,T550A,T550B,T850,T850A,T850B,
     &     T1400,T1400A,T1400B,T2000,T2000A,T2000B 
      REAL P350A,P350B,P550A,P550B,P850A,P850B,
     &     P1400A,P1400B,P2000A,P2000B 
      REAL E350,E350A,E350B,E550,E550A,E550B,E850,E850A,E850B,
     &     E1400,E1400A,E1400B,E2000,E2000A,E2000B 
      REAL TP350A,TP350B,TP550A,TP550B,TP850A,TP850B,
     &     TP140A,TP140B,TP200A,TP200B
      INTEGER FUN
      INTEGER I
      DATA B/1.259921D0  ,-0.1984259D0 ,-0.04686632D0,-0.01314096D0,
     &      -0.00308824D0, 0.00082777D0,-0.00105877D0, 0.00183142D0/
C////////////////////////////////coefficients - main model part//////////////////////
      DATA (MIRREQ(J),J=1,81)/
     &  1,-1, 1,-1, 1,-1, 1,-1, 1, 1,-1, 1,-1, 1,-1, 1,-1, 1,-1, 1,-1,
     &  1,-1, 1,-1, 1,-1, 1,-1, 1,-1, 1, 1,-1, 1,-1, 1,-1, 1, 1,-1, 1,
     & -1, 1,-1, 1,-1, 1,-1, 1,-1, 1,-1, 1,-1, 1, 1,-1, 1,-1, 1, 1,-1,
     &  1,-1, 1,-1, 1,-1, 1,-1, 1, 1,-1, 1, 1,-1, 1,-1, 1, 1/
      CALL KOEFD(MIRREQ,D)
      CALL KODERR(MIRREQ,DERRTE)
      CALL KOF107(MIRREQ,DPF107)
C//////////////////////thresholds of solar activity/////////////////////////////////////
      IF (PF107 .GT. 250) PF107=250
      IF (PF107 .LT. 80) PF107=80
C////////////////////////////////////////////////////////////////////////////////////
      DPI=3.1415926535897
      DTOR=DPI/180.0
      IF (CRD .EQ. 1) THEN
C      calculation of INVDIP from FL, DIMO, BO, and DIPL
C      invariant latitude calculated by highly
C      accurate polynomial expansion
       A=(DIMO/B0)**(1.0D0/3.0D0)/FL
       ASA=A*(B(1)+B(2)*A+B(3)*A**2+B(4)*A**3+B(5)*A**4+
     &        B(6)*A**5+B(7)*A**6+B(8)*A**7)
       IF (ASA .GT. 1.0) ASA=1.0
       IF (ASA .LT. 0.0) ASA=0.0
C      invariant latitude (absolute value)
       RINVL=ACOS(SQRT(ASA))
       INVL=RINVL/DTOR
       RDIPL=DIPL*DTOR
       ALFA=SIN(ABS(RDIPL))**3
       BETA=COS(RINVL)**3
       INVDP=(ALFA*SIGN(1.0,DIPL)*INVL+BETA*DIPL)/(ALFA+BETA)
      ELSE IF	(CRD .EQ. 0) THEN
       INVDP=INVDIP
      ELSE
       RETURN
      END IF
      RMLT=MLT*DTOR*15.0
      RCOLAT=(90.0-INVDP)*DTOR
      CALL SPHARM_IK(C,8,8,RCOLAT,RMLT)
C     21.3. - 20.6.
      IF ((DDD .GE. 79) .AND. (DDD .LT. 171)) THEN
       SEZA=1
       SEZB=2
       DDDA=79
       DDDB=171
       DDDD=DDD
       FUN=0
      END IF
C     21.6. - 22.9.
      IF ((DDD .GE. 171) .AND. (DDD .LT. 265)) THEN
       SEZA=2
       SEZB=1
       DDDA=171
       DDDB=265
       DDDD=DDD
       FUN=1
      END IF
C     23.9. - 20.12.
      IF ((DDD .GE. 265) .AND. (DDD .LT. 354)) THEN
       SEZA=1
       SEZB=3
       DDDA=265
       DDDB=354
       DDDD=DDD
       FUN=0
      END IF
C     21.12. - 20.3.
      IF ((DDD .GE. 354) .OR. (DDD .LT. 79)) THEN
       SEZA=3
       SEZB=1
       DDDA=354
       DDDB=365+79
       DDDD=DDD
        IF (DDD .GE. 354) THEN
         DDDD=DDD
        ELSE
         DDDD=DDD+365
        END IF
       FUN=1 
      END IF
C     model Te
      T350A=0.0
      T350B=0.0
      T550A=0.0
      T550B=0.0
      T850A=0.0
      T850B=0.0
      T1400A=0.0
      T1400B=0.0
      T2000A=0.0
      T2000B=0.0                
      DO 30 I=1,81
       T350A=T350A+C(I)*D(1,SEZA,I)
       T350B=T350B+C(I)*D(1,SEZB,I)
       T550A=T550A+C(I)*D(2,SEZA,I)
       T550B=T550B+C(I)*D(2,SEZB,I)
       T850A=T850A+C(I)*D(3,SEZA,I)
       T850B=T850B+C(I)*D(3,SEZB,I)
       T1400A=T1400A+C(I)*D(4,SEZA,I)
       T1400B=T1400B+C(I)*D(4,SEZB,I)
       T2000A=T2000A+C(I)*D(5,SEZA,I)
30     T2000B=T2000B+C(I)*D(5,SEZB,I)
      T350A=10**T350A
      T350B=10**T350B
      T550A=10**T550A
      T550B=10**T550B
      T850A=10**T850A
      T850B=10**T850B
      T1400A=10**T1400A
      T1400B=10**T1400B
      T2000A=10**T2000A
      T2000B=10**T2000B
C     model PF107
      P350A=0.0
      P350B=0.0
      P550A=0.0
      P550B=0.0
      P850A=0.0
      P850B=0.0
      P1400A=0.0
      P1400B=0.0
      P2000A=0.0
      P2000B=0.0                
      DO 40 I=1,81
       P350A=P350A+C(I)*DPF107(1,SEZA,I)
       P350B=P350B+C(I)*DPF107(1,SEZB,I)
       P550A=P550A+C(I)*DPF107(2,SEZA,I)
       P550B=P550B+C(I)*DPF107(2,SEZB,I)
       P850A=P850A+C(I)*DPF107(3,SEZA,I)
       P850B=P850B+C(I)*DPF107(3,SEZB,I)
       P1400A=P1400A+C(I)*DPF107(4,SEZA,I)
       P1400B=P1400B+C(I)*DPF107(4,SEZB,I)
       P2000A=P2000A+C(I)*DPF107(5,SEZA,I)
40     P2000B=P2000B+C(I)*DPF107(5,SEZB,I)
      P350A=10**P350A
      P350B=10**P350B
      P550A=10**P550A
      P550B=10**P550B
      P850A=10**P850A
      P850B=10**P850B
      P1400A=10**P1400A
      P1400B=10**P1400B
      P2000A=10**P2000A
      P2000B=10**P2000B
C     model errTe
      E350A=0.0
      E350B=0.0
      E550A=0.0
      E550B=0.0
      E850A=0.0
      E850B=0.0
      E1400A=0.0
      E1400B=0.0
      E2000A=0.0
      E2000B=0.0                
      DO 50 I=1,81
       E350A=E350A+C(I)*DERRTE(1,SEZA,I)
       E350B=E350B+C(I)*DERRTE(1,SEZB,I)
       E550A=E550A+C(I)*DERRTE(2,SEZA,I)
       E550B=E550B+C(I)*DERRTE(2,SEZB,I)
       E850A=E850A+C(I)*DERRTE(3,SEZA,I)
       E850B=E850B+C(I)*DERRTE(3,SEZB,I)
       E1400A=E1400A+C(I)*DERRTE(4,SEZA,I)
       E1400B=E1400B+C(I)*DERRTE(4,SEZB,I)
       E2000A=E2000A+C(I)*DERRTE(5,SEZA,I)
50     E2000B=E2000B+C(I)*DERRTE(5,SEZB,I)
      E350A=10**E350A
      E350B=10**E350B
      E550A=10**E550A
      E550B=10**E550B
      E850A=10**E850A
      E850B=10**E850B
      E1400A=10**E1400A
      E1400B=10**E1400B
      E2000A=10**E2000A
      E2000B=10**E2000B 
C
      IF (PF107Y .EQ. 1) THEN
       CALL TPCORR(INVDP,MLT,DDD,PF107,
     &             P350A,P350B,P550A,P550B,P850A,P850B,
     &             P1400A,P1400B,P2000A,P2000B, 
     &             TP350A,TP350B,TP550A,TP550B,TP850A,TP850B,
     &             TP140A,TP140B,TP200A,TP200B) 
       T350A=T350A+TP350A
       T350B=T350B+TP350B
       T550A=T550A+TP550A
       T550B=T550B+TP550B
       T850A=T850A+TP850A
       T850B=T850B+TP850B
       T1400A=T1400A+TP140A
       T1400B=T1400B+TP140B
       T2000A=T2000A+TP200A
       T2000B=T2000B+TP200B
      END IF 
C     Te
      IF (FUN .EQ. 0) THEN
       SEZDAY=(DDDB-DDDA)
       XDAY=DDDD-DDDA
       T350=(T350B-T350A)*SIN(DPI/2.0*XDAY/SEZDAY)+T350A
       T550=(T550B-T550A)*SIN(DPI/2.0*XDAY/SEZDAY)+T550A
       T850=(T850B-T850A)*SIN(DPI/2.0*XDAY/SEZDAY)+T850A
       T1400=(T1400B-T1400A)*SIN(DPI/2.0*XDAY/SEZDAY)+T1400A
       T2000=(T2000B-T2000A)*SIN(DPI/2.0*XDAY/SEZDAY)+T2000A
      ELSE
       SEZDAY=(DDDB-DDDA)
       XDAY=DDDD-DDDA
       T350=(T350A-T350B)*COS(DPI/2.0*XDAY/SEZDAY)+T350B
       T550=(T550A-T550B)*COS(DPI/2.0*XDAY/SEZDAY)+T550B
       T850=(T850A-T850B)*COS(DPI/2.0*XDAY/SEZDAY)+T850B
       T1400=(T1400A-T1400B)*COS(DPI/2.0*XDAY/SEZDAY)+T1400B
       T2000=(T2000A-T2000B)*COS(DPI/2.0*XDAY/SEZDAY)+T2000B
      END IF
C     error Te
      IF (FUN .EQ. 0) THEN
       SEZDAY=(DDDB-DDDA)
       XDAY=DDDD-DDDA
       E350=(E350B-E350A)*SIN(DPI/2.0*XDAY/SEZDAY)+E350A
       E550=(E550B-E550A)*SIN(DPI/2.0*XDAY/SEZDAY)+E550A
       E850=(E850B-E850A)*SIN(DPI/2.0*XDAY/SEZDAY)+E850A
       E1400=(E1400B-E1400A)*SIN(DPI/2.0*XDAY/SEZDAY)+E1400A
       E2000=(E2000B-E2000A)*SIN(DPI/2.0*XDAY/SEZDAY)+E2000A
      ELSE
       SEZDAY=(DDDB-DDDA)
       XDAY=DDDD-DDDA
       E350=(E350A-E350B)*COS(DPI/2.0*XDAY/SEZDAY)+E350B
       E550=(E550A-E550B)*COS(DPI/2.0*XDAY/SEZDAY)+E550B
       E850=(E850A-E850B)*COS(DPI/2.0*XDAY/SEZDAY)+E850B
       E1400=(E1400A-E1400B)*COS(DPI/2.0*XDAY/SEZDAY)+E1400B
       E2000=(E2000A-E2000B)*COS(DPI/2.0*XDAY/SEZDAY)+E2000B
      END IF      
C ////////////////////////////////////////////////////////
C     Te linear interpolation for altitude
      IF (ALT .LT. 550) THEN
       TE=(T550-T350)/200.0*(ALT-350)+T350
       SIGTE=(E550-E350)/200.0*(ALT-350)+E350    
      END IF
      IF ((ALT .GE. 550) .AND. (ALT .LT. 850)) THEN       
       TE=(T850-T550)/300.0*(ALT-550)+T550
       SIGTE=(E850-E550)/300.0*(ALT-550)+E550    
      END IF
      IF ((ALT .GE. 850) .AND. (ALT .LT. 1400)) THEN       
       TE=(T1400-T850)/550.0*(ALT-850)+T850
       SIGTE=(E1400-E850)/550.0*(ALT-850)+E850    
      END IF
      IF (ALT .GE. 1400) THEN       
       TE=(T2000-T1400)/600.0*(ALT-1400)+T1400
       SIGTE=(E2000-E1400)/600.0*(ALT-1400)+E1400    
      END IF 
      
      INVDIP=INVDP
           
      RETURN
      END
C
C
       REAL FUNCTION INTERP(N,L,V,X,XOUT)
C---------------------------------------------------------------------------------
        INTEGER N,L,S,S0,I
        REAL V(N),X(N),XOUT,Y2(N),YOUT,X0(4),V0(4)
        REAL XA,XB,XC,VA,VB,VC
        CALL locate(X,N,XOUT,S)
        IF (L .EQ. 0) THEN   
C       Spline interpolation (L=0)       
         IF (S .LT. 2) S=2
         IF (S .GT. (N-2)) S=N-2    
         S0=S-1 
         DO 10 I=1,4
          X0(I)=X(S0+I-1)
10        V0(I)=V(S0+I-1)
         CALL SPLINE(X0,V0,4,1e30,1e30,Y2)              
         CALL SPLINT(X0,V0,Y2,4,XOUT,YOUT)
        END IF 
        IF (L .EQ. 1) THEN
C       Linear interpolation (L=1)       
         IF ((S .GE.1) .AND. (S .LT. N)) THEN
          YOUT=(V(S+1)-V(S))/(X(S+1)-X(S))*(XOUT-X(S))+V(S)
         END IF
         IF (S .EQ. 0) THEN 
          YOUT=(V(2)-V(1))/(X(2)-X(1))*(XOUT-X(1))+V(1)
         END IF
         IF (S .EQ. N) THEN 
          YOUT=(V(N)-V(N-1))/(X(N)-X(N-1))*(XOUT-X(N))+V(N)
         END IF  
        END IF        
         IF (L .EQ. 2) THEN
C       Quadratic interpolation (L=2)    
         IF (S .LT. 2) S=2
         IF (S .GT. (N-1)) S=N-1    
          XA=X(S-1)
          XB=X(S)
          XC=X(S+1)
          VA=V(S-1)
          VB=V(S)
          VC=V(S+1)
          YOUT=VA*(XOUT-XB)*(XOUT-XC)/((XA-XB)*(XA-XC))+
     &         VB*(XOUT-XA)*(XOUT-XC)/((XB-XA)*(XB-XC))+
     &         VC*(XOUT-XA)*(XOUT-XB)/((XC-XA)*(XC-XB))        
         END IF         
        INTERP=YOUT
        RETURN
       END
C
C
      SUBROUTINE KODERR(MIRREQ,DOUT)
C------------------------------------------------------------------------------------
C coefficients - error model part
C------------------------------------------------------------------------------------
      REAL DOUT(5,3,81)
      INTEGER MIRREQ(81),I,J,K
      REAL DERRTE(5,3,81)
C     350km equinox
      DATA (DERRTE(1,1,J),J=1,81)/ 2.1178E+00, 1.3114E-07, 2.6148E-01,
     &                            -2.8483E-07,-8.3770E-02,-2.3135E-08,
     &                             5.7835E-02,-9.9532E-08,-2.0735E-02,
     &                            -1.9633E-01, 4.4717E-08, 5.0244E-02,
     &                            -9.1274E-09, 4.8611E-02, 2.5790E-08,
     &                             1.2098E-02,-3.3205E-08, 6.4414E-02,
     &                             2.4963E-08, 2.6340E-03,-3.3202E-08,
     &                             1.0058E-02, 1.0816E-09,-1.3928E-02,
     &                             1.4163E-08,-1.5039E-01, 1.0533E-08,
     &                            -4.5060E-03, 8.3297E-09, 2.4488E-03,
     &                            -3.7760E-09,-1.8094E-03, 9.6798E-02,
     &                            -1.8772E-09, 1.0867E-02,-1.9474E-09,
     &                            -6.8032E-03, 3.3603E-09, 7.8251E-03,
     &                             1.6945E-01,-1.1341E-08,-2.0581E-02,
     &                            -1.9111E-09,-5.8315E-03,-5.3837E-11,
     &                            -3.5216E-02,-3.3668E-09, 1.1079E-03,
     &                             8.5225E-09, 4.8433E-03,-2.6840E-09,
     &                             9.9141E-02,-1.0567E-08, 1.8306E-03,
     &                             1.9576E-10, 1.5468E-03, 1.6529E-01,
     &                            -8.3743E-09,-1.0179E-02,-1.0826E-09,
     &                            -1.4207E-03,-4.8573E-02, 1.1394E-08,
     &                             1.4470E-02, 2.6626E-10, 9.4379E-02,
     &                            -1.8262E-08,-2.0741E-03, 1.3797E-09,
     &                             5.9985E-03, 1.8945E-10, 3.4170E-04,
     &                             6.8581E-02, 5.7838E-09, 6.9529E-03,
     &                             1.5896E-02,-5.0075E-09, 2.8420E-02,
     &                            -4.8417E-09, 2.9191E-02, 4.8866E-02/
C     350km June solstice
      DATA (DERRTE(1,2,J),J=1,81)/ 2.1020E+00, 6.4074E-02, 8.8979E-02,
     &                            -1.6295E-01,-6.8680E-02,-4.9903E-02,
     &                             2.7634E-02, 5.3483E-02,-3.6534E-02,
     &                            -2.3004E-01, 5.3630E-02, 9.0376E-02,
     &                             2.6442E-02, 3.7594E-02, 1.7345E-02,
     &                            -4.3779E-02,-4.7004E-03, 9.0849E-02,
     &                             2.6102E-02,-3.2626E-02,-1.1288E-03,
     &                             2.4115E-02,-1.8059E-03,-3.9570E-03,
     &                             5.6676E-03,-6.3478E-02, 1.5132E-02,
     &                             3.1012E-02,-1.7904E-04,-1.7065E-04,
     &                            -6.6273E-03, 5.2600E-03,-1.5202E-01,
     &                             2.2061E-02, 1.0633E-02,-2.8630E-03,
     &                            -9.6908E-03,-1.3059E-03, 2.4577E-03,
     &                             9.1133E-02, 1.0057E-02, 7.1922E-04,
     &                             2.9878E-03, 7.7424E-04,-4.4353E-03,
     &                            -7.6271E-03, 1.4035E-02,-1.3870E-02,
     &                             1.6514E-03, 1.3885E-03, 7.7953E-04,
     &                             1.1731E-01, 2.3511E-02,-8.2554E-04,
     &                            -2.4741E-03, 1.5413E-04, 3.3407E-02,
     &                            -5.2112E-04,-6.3114E-03, 5.3990E-03,
     &                            -9.1618E-04, 1.1605E-02, 1.2671E-03,
     &                            -2.1350E-03, 2.6276E-03, 8.2348E-02,
     &                            -2.2401E-06,-1.4076E-03, 1.6459E-03,
     &                            -4.3340E-02, 1.4798E-02, 4.6935E-03,
     &                             3.0577E-02, 6.6725E-03, 9.0547E-03,
     &                            -1.5337E-02,-4.3676E-03,-6.5343E-02,
     &                             1.1111E-02, 2.3191E-03,-3.1603E-02/
C     550km equinox
      DATA (DERRTE(2,1,J),J=1,81)/ 2.0812E+00, 2.4308E-07, 5.6584E-01,
     &                             1.9086E-08,-7.6095E-02,-5.1032E-07,
     &                            -1.7049E-01,-1.0472E-08, 6.7164E-02,
     &                            -2.2595E-01, 4.2122E-09, 6.1906E-03,
     &                             3.9518E-08, 4.5763E-02,-2.2074E-08,
     &                            -1.1397E-02,-1.0607E-08, 1.6385E-01,
     &                             4.4170E-08,-2.2410E-02,-1.5556E-08,
     &                             1.2078E-02,-2.9345E-08,-2.3789E-03,
     &                             5.0526E-08,-2.4343E-01, 1.6201E-08,
     &                             1.9976E-02,-2.2397E-11, 4.6519E-03,
     &                            -1.1324E-09,-2.2603E-03,-1.2091E-01,
     &                             6.5523E-09, 2.3472E-02, 1.2557E-10,
     &                             3.5617E-03, 2.1655E-09,-1.3878E-03,
     &                            -2.4845E-02,-3.1878E-09,-1.3496E-02,
     &                             3.2648E-09,-8.7088E-04,-3.2223E-09,
     &                            -8.9965E-02, 1.6719E-09, 5.9083E-03,
     &                             7.0153E-10, 6.3045E-06,-1.7459E-09,
     &                             1.1872E-01, 3.4154E-09, 8.3146E-03,
     &                             7.3305E-11,-1.5977E-04, 2.3161E-02,
     &                             1.6234E-09,-9.7428E-03,-3.1068E-10,
     &                             1.1073E-03, 6.8273E-02, 7.3145E-09,
     &                             4.3073E-03, 1.3123E-10, 1.7105E-02,
     &                             1.9378E-09,-1.6849E-03, 3.9189E-10,
     &                             1.4436E-02,-7.5937E-10, 5.5921E-04,
     &                             3.0434E-02,-5.3588E-10, 1.7285E-03,
     &                            -4.6172E-02, 1.0424E-09,-3.3645E-02,
     &                             4.5595E-10,-1.0524E-02,-6.6919E-02/
C     550km June solstice
      DATA (DERRTE(2,2,J),J=1,81)/ 2.0903E+00, 4.9465E-02, 4.1834E-01,
     &                            -3.0721E-02,-1.0157E-01,-1.5666E-01,
     &                            -7.6741E-02, 1.2230E-01, 3.1210E-02,
     &                            -1.5269E-01, 4.5530E-02,-2.1376E-03,
     &                            -1.8327E-02, 2.3483E-02, 3.1872E-02,
     &                            -2.3882E-02,-1.4407E-02, 4.4489E-02,
     &                             1.4618E-02,-2.3584E-04,-6.5495E-03,
     &                             1.6602E-02,-7.5274E-03,-1.3698E-02,
     &                            -8.2527E-03,-2.1590E-01, 2.5813E-02,
     &                             5.0590E-02, 2.1022E-03, 1.0141E-02,
     &                            -5.1961E-03, 5.4961E-03, 9.7779E-03,
     &                             1.5319E-02,-1.0422E-02,-9.1045E-03,
     &                            -8.1248E-03,-5.5846E-03, 1.2857E-03,
     &                            -3.1836E-02,-4.4886E-03,-1.8187E-02,
     &                            -1.0253E-03,-4.4267E-04,-1.6932E-03,
     &                            -8.0883E-02, 2.2869E-02, 3.6385E-03,
     &                             6.0430E-03, 1.8587E-03,-1.5704E-03,
     &                             5.2741E-02, 2.3327E-03,-8.1670E-03,
     &                             2.3873E-03,-4.6541E-04,-5.5659E-02,
     &                             1.0942E-02,-1.0447E-02,-4.5905E-04,
     &                             2.9831E-04, 9.2199E-02,-8.8334E-03,
     &                             4.9657E-03,-1.2876E-03, 1.5785E-02,
     &                            -1.1838E-02,-2.4461E-04, 8.0350E-04,
     &                             8.4769E-03, 7.2212E-03, 1.2089E-03,
     &                             4.0519E-02,-8.4599E-03, 1.1588E-03,
     &                            -3.3485E-02, 5.8463E-03,-2.8652E-03,
     &                             8.8555E-03,-2.6834E-02,-5.0552E-02/
C     850km equinox
      DATA (DERRTE(3,1,J),J=1,81)/ 2.1741E+00,-3.0713E-07, 7.0198E-02,
     &                             4.9868E-07,-1.4427E-01, 2.8235E-08,
     &                             2.9561E-02,-8.1150E-07, 1.8500E-03,
     &                             8.5103E-02, 3.3995E-09, 3.7822E-02,
     &                             4.4995E-08, 3.8160E-02, 6.1687E-09,
     &                            -7.6820E-03,-3.5958E-08, 5.4672E-02,
     &                             1.5964E-10, 1.6325E-02,-2.9809E-08,
     &                            -2.8099E-03, 2.0887E-08,-1.6249E-03,
     &                             6.0045E-09,-4.3312E-02, 1.2503E-08,
     &                             3.9802E-02, 1.6466E-08, 1.4980E-02,
     &                            -7.7490E-09, 4.3219E-03, 1.0214E-01,
     &                            -1.6204E-08, 8.0035E-03, 3.9310E-09,
     &                            -2.1047E-04,-2.0211E-10, 2.3744E-03,
     &                            -1.0833E-01,-2.6971E-09,-1.8076E-02,
     &                             3.9598E-09, 8.3868E-05,-1.0948E-10,
     &                             7.6547E-02, 1.1306E-09,-1.5295E-02,
     &                            -8.6391E-10,-9.3252E-04,-9.1719E-12,
     &                             6.3563E-02,-1.2694E-08,-6.3280E-03,
     &                             5.2632E-10,-7.9613E-04,-1.1528E-02,
     &                             1.0676E-08, 1.0950E-02,-5.2360E-09,
     &                            -1.0426E-03,-8.4653E-03, 2.7643E-09,
     &                            -1.0339E-03, 1.0439E-09, 8.2576E-02,
     &                            -1.0238E-08,-5.2244E-03,-2.8944E-10,
     &                             1.7164E-02,-3.7405E-09, 1.3255E-03,
     &                            -1.6994E-02, 4.5616E-09, 1.3458E-03,
     &                             2.5439E-02,-5.2198E-09, 3.0276E-02,
     &                            -3.3313E-09,-5.7659E-02, 2.8990E-02/
C     850km June solstice
      DATA (DERRTE(3,2,J),J=1,81)/ 2.1685E+00,-9.1071E-02,-1.2046E-01,
     &                            -2.0084E-01,-7.3145E-02,-1.2735E-01,
     &                            -5.5899E-02, 5.2264E-02, 2.3232E-02,
     &                             2.8355E-02,-3.9715E-02, 6.7638E-02,
     &                             2.3396E-02,-8.2230E-03, 1.1384E-02,
     &                            -1.6781E-02,-1.7576E-03,-8.0253E-02,
     &                            -3.9270E-02,-1.0264E-02,-1.7191E-03,
     &                            -4.4668E-03,-1.2252E-04,-7.9374E-03,
     &                             2.3770E-03, 5.3901E-02,-1.9019E-03,
     &                             3.2748E-02, 8.1218E-03, 3.1385E-03,
     &                             6.5387E-03, 1.9147E-03, 9.6127E-02,
     &                            -2.7965E-02,-7.7649E-03, 3.7879E-03,
     &                            -4.0496E-03, 6.9544E-03,-5.2783E-04,
     &                            -1.5082E-01, 1.2699E-02,-1.2565E-03,
     &                             6.7728E-03, 3.6761E-03,-1.7899E-03,
     &                            -6.4801E-02,-1.7940E-02,-1.3257E-02,
     &                             5.2332E-03,-6.6084E-03,-2.9180E-03,
     &                             3.0122E-02, 2.1713E-02,-8.3407E-03,
     &                             1.1084E-03, 9.2082E-04,-8.5997E-02,
     &                            -1.4387E-02, 9.3689E-03, 6.2303E-04,
     &                             3.5905E-04, 1.7038E-02,-6.3187E-03,
     &                             3.6498E-03, 5.2909E-04,-7.0981E-03,
     &                             5.5184E-03, 6.6041E-04, 3.3276E-04,
     &                             6.9458E-02,-4.9348E-03, 6.0775E-03,
     &                            -5.0934E-02,-4.4936E-03, 1.3723E-03,
     &                            -8.1570E-03, 1.3748E-02, 7.0236E-03,
     &                             7.9914E-04,-4.6833E-02,-1.6385E-02/
C     1400km equinox
      DATA (DERRTE(4,1,J),J=1,81)/ 2.1822E+00, 3.3549E-08, 1.2164E-01,
     &                             2.4764E-07,-8.7502E-02,-4.0691E-07,
     &                             2.3355E-03,-2.8158E-07,-1.3242E-03,
     &                             1.4782E-02, 1.5416E-08, 8.8183E-02,
     &                             2.7046E-08,-2.2398E-02,-4.4919E-09,
     &                            -7.8416E-03,-1.7223E-08,-1.3115E-02,
     &                             2.6125E-08, 5.3183E-02,-2.9019E-08,
     &                            -3.7068E-04, 5.4685E-10, 1.7274E-03,
     &                             1.8592E-08,-6.2685E-02,-5.3055E-09,
     &                             3.1005E-02, 1.7579E-09, 2.4121E-03,
     &                             4.4444E-11, 4.1500E-03,-2.4028E-01,
     &                            -2.3704E-08, 8.7659E-03, 4.2252E-09,
     &                             4.8969E-03, 4.0202E-10, 1.9055E-03,
     &                            -1.6350E-01, 3.2289E-09, 1.4824E-03,
     &                            -3.6081E-09, 1.3517E-03, 2.4239E-09,
     &                            -1.6658E-01, 1.0138E-09, 1.3305E-02,
     &                             4.1669E-09, 1.8869E-03,-2.0831E-09,
     &                             2.0076E-02,-1.0135E-08, 2.2258E-03,
     &                            -1.2563E-09,-1.3067E-03,-1.8645E-01,
     &                             2.1705E-09,-7.8197E-03,-9.9205E-10,
     &                             9.4107E-04, 1.7436E-01,-2.0898E-09,
     &                             7.8659E-03, 2.7303E-10, 7.1875E-02,
     &                            -2.0799E-09,-3.6387E-03, 2.5309E-09,
     &                            -9.2385E-02, 1.1905E-09, 2.6655E-03,
     &                            -2.4122E-02, 6.0810E-10, 5.8355E-03,
     &                            -5.1302E-02,-7.9405E-09,-7.6189E-02,
     &                            -6.7824E-10,-3.1716E-02,-4.1055E-02/
C     1400km June solstice
      DATA (DERRTE(4,2,J),J=1,81)/ 2.1442E+00,-1.3864E-01, 1.7112E-01,
     &                            -2.1389E-01,-1.8186E-02,-1.0237E-01,
     &                             5.9302E-02, 6.0929E-02, 2.4732E-02,
     &                             7.8690E-02,-2.1925E-02, 1.2199E-01,
     &                            -2.8987E-02,-5.3213E-02,-4.8915E-03,
     &                             4.6986E-03,-1.1799E-02,-2.4101E-02,
     &                            -2.2908E-02, 2.3052E-02,-8.2149E-03,
     &                             3.1831E-03,-7.8876E-04, 9.0815E-03,
     &                             2.5709E-03,-1.9943E-01, 1.6644E-02,
     &                             3.6662E-02, 8.7738E-03,-2.2514E-03,
     &                            -3.0569E-04, 3.6344E-04, 5.6322E-02,
     &                             1.1496E-02, 1.8602E-02,-1.9180E-03,
     &                             6.0620E-03,-6.3761E-04, 3.2952E-03,
     &                            -1.4087E-01, 8.0978E-03, 4.2363E-03,
     &                             5.9284E-03, 9.9418E-04, 1.9006E-03,
     &                            -9.8914E-02, 8.8500E-03, 2.2600E-03,
     &                             4.5221E-05,-1.4855E-04, 6.4891E-04,
     &                             3.2002E-02,-1.8770E-02, 2.5766E-04,
     &                             6.8798E-04, 7.8152E-04,-5.2227E-02,
     &                             1.3226E-03,-1.6813E-03, 4.7524E-05,
     &                            -3.5793E-04, 6.7469E-02,-1.0750E-02,
     &                            -2.0372E-03, 2.9722E-04, 4.0765E-02,
     &                            -1.4128E-02,-6.7906E-03, 6.6127E-04,
     &                             2.0483E-02, 2.7251E-03,-3.2169E-04,
     &                             7.7473E-02,-6.8423E-03,-1.5793E-03,
     &                            -2.6085E-02, 8.8083E-03, 4.2452E-02,
     &                             8.2699E-04, 2.1088E-02, 1.7894E-02/
C     2000km equinox
      DATA (DERRTE(5,1,J),J=1,81)/ 2.4436E+00,-4.3843E-07, 1.5425E-01,
     &                            -5.5662E-08, 4.0385E-03, 8.1161E-07,
     &                             5.3553E-02,-6.9405E-07,-1.8544E-02,
     &                             1.7362E-01, 4.5975E-08,-6.9333E-03,
     &                             6.9511E-10,-1.9003E-02, 2.0966E-08,
     &                            -2.9413E-04,-4.3705E-08, 1.4120E-02,
     &                            -4.4319E-08, 2.6738E-02,-1.3382E-09,
     &                            -7.7713E-03,-2.1625E-08, 6.7646E-03,
     &                             2.9648E-08,-4.9498E-03,-6.9172E-09,
     &                             1.8036E-02, 8.0627E-09, 1.6950E-03,
     &                            -8.2902E-11, 2.3367E-04, 1.2521E-02,
     &                            -2.9426E-08,-1.0396E-02, 8.0042E-10,
     &                             3.0297E-03, 2.7689E-10,-9.5301E-04,
     &                            -2.3612E-02,-7.9111E-10,-7.6654E-03,
     &                             2.9311E-10,-2.8914E-04, 8.3715E-11,
     &                            -7.8202E-02, 6.6501E-09, 3.8289E-03,
     &                             4.0403E-09, 1.6187E-03,-5.7231E-10,
     &                             6.4240E-02,-3.3474E-09,-1.3766E-03,
     &                            -5.7988E-10, 6.2600E-04, 3.8725E-03,
     &                             1.5940E-08,-5.3759E-03,-2.1427E-09,
     &                            -8.9545E-04, 3.5896E-02,-4.3521E-09,
     &                             2.9789E-03, 1.0916E-09, 7.4931E-02,
     &                            -4.2211E-09,-8.2421E-03, 1.4316E-09,
     &                            -2.6314E-02,-4.4286E-10,-3.5706E-03,
     &                             6.3435E-02,-2.5381E-09,-2.2050E-03,
     &                            -6.6893E-02, 1.6210E-09, 4.0881E-02,
     &                            -5.1892E-09, 9.0158E-03, 2.3495E-02/
C     2000km June solstice
      DATA (DERRTE(5,2,J),J=1,81)/ 2.4223E+00,-1.6581E-01, 2.0883E-01,
     &                            -8.0645E-02,-3.9722E-02, 1.5954E-02,
     &                             3.0088E-02,-9.6053E-03, 7.4229E-03,
     &                             1.4053E-01, 7.9878E-03, 4.2976E-02,
     &                            -2.6882E-02,-1.1069E-02,-5.6813E-03,
     &                             3.1338E-03,-7.3863E-03,-9.6881E-03,
     &                            -4.0146E-02, 1.3978E-02,-1.6224E-02,
     &                             9.3162E-03,-1.0888E-02,-1.4472E-02,
     &                            -5.4611E-03,-5.0694E-02, 5.5719E-02,
     &                             6.4098E-03, 2.0679E-03,-3.4277E-03,
     &                             2.9826E-03, 2.2637E-03, 4.8907E-02,
     &                             8.6854E-03, 6.6625E-03, 3.3814E-03,
     &                             7.7458E-04, 2.9699E-03,-6.9636E-04,
     &                            -9.5779E-03, 1.6612E-03, 1.3018E-02,
     &                            -5.0237E-03,-1.6025E-03, 1.3429E-03,
     &                             2.9054E-02, 7.2855E-03,-1.3993E-02,
     &                            -5.2888E-03,-2.7511E-05, 2.6011E-04,
     &                             1.5534E-02,-1.6128E-02, 6.3239E-03,
     &                            -3.7710E-03, 7.4519E-04,-5.6335E-02,
     &                             1.4123E-02, 7.2038E-03,-8.2835E-04,
     &                            -3.9963E-04, 2.0466E-02, 1.4346E-02,
     &                            -3.4267E-03, 5.6522E-04,-6.6495E-02,
     &                            -6.4634E-04, 4.2662E-04, 1.3420E-03,
     &                             2.0465E-02, 6.0863E-04, 4.9604E-04,
     &                            -2.2755E-02,-7.0387E-03, 1.3109E-03,
     &                             3.6849E-02, 2.2601E-03, 2.2893E-02,
     &                            -1.1385E-02, 4.4417E-02,-6.5754E-03/
      DO 10 I=1,81
       DERRTE(1,3,I)=DERRTE(1,2,I)*MIRREQ(I)
       DERRTE(2,3,I)=DERRTE(2,2,I)*MIRREQ(I)
       DERRTE(3,3,I)=DERRTE(3,2,I)*MIRREQ(I)
       DERRTE(4,3,I)=DERRTE(4,2,I)*MIRREQ(I)
10     DERRTE(5,3,I)=DERRTE(5,2,I)*MIRREQ(I)
      DO 40 K=1,81
       DO 30 J=1,3
        DO 20 I=1,5 
         DOUT(I,J,K)=DERRTE(I,J,K)
20      CONTINUE
30     CONTINUE
40    CONTINUE
C////////////////////////////////////////////////////////////////////////////////////
      RETURN
      END
C
C
      SUBROUTINE KOEFD(MIRREQ,DOUT)
C------------------------------------------------------------------------------------
C    coefficients - main model part
C------------------------------------------------------------------------------------
      REAL DOUT(5,3,81)
      INTEGER MIRREQ(81),I,J,K
      REAL D(5,3,81)
C     350km equinox
      DATA (D(1,1,J),J=1,81)/ 3.1753E+00, 5.7689E-07, 1.9586E-01,
     &                       -6.8275E-07, 1.8921E-02, 3.6213E-07,
     &                       -1.8628E-02, 5.0105E-08,-8.5600E-03,
     &                       -1.6010E-01,-9.6605E-08,-1.9714E-02,
     &                        2.1637E-07, 4.8494E-03,-3.8884E-07,
     &                       -3.4967E-03, 2.2421E-07, 2.1263E-02,
     &                        9.3647E-08,-7.9466E-03, 1.0780E-07,
     &                        9.0129E-03,-1.2648E-07, 9.2017E-05,
     &                        5.0372E-08,-7.7926E-02,-5.7641E-08,
     &                       -9.1840E-03,-2.8697E-08, 8.4038E-04,
     &                       -3.3483E-09, 9.8633E-04,-3.6580E-02,
     &                        2.6765E-07, 9.6558E-03, 3.1708E-09,
     &                       -3.7801E-04,-1.4056E-08,-7.5288E-04,
     &                        5.8945E-02,-6.4803E-08, 6.6372E-03,
     &                       -5.1910E-08, 6.6456E-05, 5.3576E-09,
     &                       -5.9863E-02,-2.4909E-07,-1.1843E-03,
     &                        4.9602E-08, 2.4969E-04,-7.2411E-09,
     &                        6.1304E-02,-9.0388E-08, 1.4235E-03,
     &                        9.6584E-09, 4.8905E-04, 3.4504E-02,
     &                        3.9764E-08, 2.2885E-04,-2.0067E-08,
     &                       -2.3446E-04,-5.3749E-02, 5.5106E-08,
     &                       -2.5829E-05,-3.6483E-10, 3.9294E-02,
     &                       -1.1888E-07,-1.1182E-04, 8.2427E-09,
     &                       -3.4563E-02,-4.2396E-08,-6.5573E-04,
     &                       -2.7676E-02,-1.3017E-08, 5.8774E-04,
     &                        1.6090E-02, 4.6780E-08,-2.0595E-02,
     &                        2.5706E-08, 1.2541E-02, 1.7794E-02/
C     350km June solstice
      DATA (D(1,2,J),J=1,81)/ 3.1629E+00, 6.1302E-02, 2.0063E-01,
     &                        4.5285E-02,-4.1826E-02, 1.9260E-03,
     &                        2.4969E-03, 8.2077E-03,-2.8539E-02,
     &                       -1.6297E-01, 1.3558E-02,-2.4389E-02,
     &                       -3.1286E-03, 2.2763E-02, 2.1271E-03,
     &                       -6.5418E-03, 9.5738E-04, 1.6215E-02,
     &                        1.8507E-03,-1.0563E-03, 1.1742E-03,
     &                       -1.0133E-03,-1.9169E-03, 3.6940E-03,
     &                       -1.5715E-04,-5.6835E-02,-4.2398E-03,
     &                        6.2377E-03,-1.5667E-03, 4.1399E-04,
     &                       -2.1687E-03, 2.0367E-04,-1.4575E-02,
     &                        8.7408E-03,-1.5991E-03, 2.2254E-03,
     &                        1.3953E-03,-6.9929E-04,-1.0188E-03,
     &                        2.6039E-02,-7.4757E-04, 2.1545E-03,
     &                        1.0206E-03, 9.9516E-05,-5.1330E-04,
     &                       -4.3098E-03, 6.8083E-04, 1.7507E-03,
     &                        1.8198E-03,-5.2904E-04,-5.0768E-04,
     &                        3.1658E-02, 4.7564E-03,-9.2531E-04,
     &                        1.7889E-03,-3.7194E-05, 1.6896E-02,
     &                       -5.0829E-04,-8.1960E-04, 4.8322E-04,
     &                       -2.6520E-05,-1.0728E-02, 4.1619E-03,
     &                        3.8523E-04, 4.9239E-05, 1.1805E-02,
     &                       -2.9327E-03, 2.9543E-04, 2.9735E-04,
     &                       -9.7455E-03,-1.6474E-03, 1.0511E-03,
     &                       -1.7878E-02, 5.3427E-03, 1.7965E-05,
     &                        3.5806E-03, 6.6563E-04,-1.2012E-02,
     &                       -5.7183E-03, 2.4944E-03, 4.3333E-03/
C     550km equinox
      DATA (D(2,1,J),J=1,81)/ 3.2751E+00, 1.3545E-06, 1.7150E-01,
     &                       -7.6203E-07, 4.0429E-02, 5.0117E-07,
     &                       -2.2589E-02, 3.0332E-08,-2.0861E-02,
     &                       -1.4168E-01, 2.7793E-07,-1.8331E-02,
     &                        2.2669E-07, 4.6414E-03, 6.9158E-08,
     &                        1.3312E-03,-1.0690E-07, 1.7280E-02,
     &                        3.6689E-07,-1.0921E-03,-4.8798E-07,
     &                        2.0699E-03, 1.5270E-07, 4.0919E-03,
     &                       -4.0587E-08,-8.4276E-02,-1.8326E-07,
     &                       -7.7966E-03, 2.9950E-07, 1.3969E-03,
     &                        2.2649E-08, 1.0082E-03,-3.1392E-02,
     &                       -5.0450E-08, 1.7356E-03,-1.4810E-08,
     &                        2.4669E-03, 2.0049E-08,-1.6503E-04,
     &                        5.6435E-02,-2.2274E-07, 4.4061E-03,
     &                       -1.8825E-08, 3.1341E-04, 1.3638E-08,
     &                       -4.7964E-02,-3.1192E-07,-3.8772E-04,
     &                        2.2998E-08,-5.8125E-05, 1.5519E-09,
     &                        4.9958E-02, 7.1110E-08, 1.6467E-03,
     &                       -3.5644E-08, 1.8249E-04, 2.7835E-02,
     &                       -1.2413E-07,-1.5793E-03, 2.2114E-08,
     &                       -3.9754E-04,-2.2227E-02, 2.2094E-07,
     &                        2.8621E-04, 5.3520E-09, 1.9280E-02,
     &                        5.1741E-08, 3.2861E-04,-1.7477E-08,
     &                       -1.9664E-02,-6.0668E-08,-3.8234E-05,
     &                       -1.8001E-02, 1.3656E-07, 4.1525E-04,
     &                        7.9458E-03,-1.0954E-07,-1.2869E-02,
     &                       -6.1937E-08, 9.2866E-03, 5.3834E-03/
C     550km June solstice
      DATA (D(2,2,J),J=1,81)/ 3.2706E+00, 3.5202E-02, 1.6153E-01,
     &                        7.5517E-02,-1.2975E-02,-1.0202E-02,
     &                       -1.4402E-02, 8.0992E-03,-2.4350E-02,
     &                       -1.5168E-01, 2.1369E-02,-1.2387E-02,
     &                       -6.1981E-03, 9.1958E-03, 2.4677E-03,
     &                       -4.9595E-04,-9.1671E-04, 1.1726E-02,
     &                        1.3928E-04,-6.8449E-03, 3.9822E-03,
     &                        6.7074E-03,-2.3986E-03, 9.3211E-04,
     &                       -1.2521E-03,-7.7734E-02, 5.3710E-03,
     &                        3.3728E-04,-6.9879E-04, 1.9755E-03,
     &                       -2.3413E-04, 7.7060E-04,-2.7894E-02,
     &                        1.2731E-02, 1.9542E-03, 2.6609E-03,
     &                       -3.5695E-04,-1.1310E-03,-6.4754E-04,
     &                        4.2322E-02,-6.9529E-03,-7.8122E-04,
     &                        1.9300E-05,-6.5241E-04,-2.0369E-05,
     &                       -3.0919E-02, 1.4165E-03, 1.9683E-03,
     &                        3.6586E-05, 2.3327E-04, 7.7364E-05,
     &                        3.6784E-02, 2.2045E-03, 2.1286E-04,
     &                        6.5019E-04, 1.3530E-04, 1.2010E-02,
     &                       -1.1533E-03,-1.0365E-03, 5.2595E-04,
     &                       -1.9816E-04,-6.4129E-03,-2.9187E-04,
     &                        6.4120E-04,-4.3814E-04, 1.9807E-02,
     &                       -1.7670E-03,-5.2232E-04,-2.5243E-05,
     &                       -1.4894E-02, 7.9595E-04, 1.8406E-04,
     &                        9.1260E-04, 5.9450E-04, 3.9428E-04,
     &                        1.7175E-03,-7.0834E-04,-7.3342E-03,
     &                        9.3208E-04, 8.0461E-03, 1.7211E-03/
C     850km equinox
      DATA (D(3,1,J),J=1,81)/ 3.4090E+00,-8.7890E-07, 1.4192E-01,
     &                        2.2022E-06,-2.3026E-02, 2.8080E-07,
     &                       -2.0490E-02,-2.4588E-06, 8.0287E-03,
     &                       -1.7872E-01,-5.9833E-07,-3.1967E-03,
     &                        5.7087E-07, 5.6724E-03,-3.6116E-08,
     &                       -3.9539E-03,-1.1406E-07, 2.5913E-02,
     &                       -4.3955E-07,-5.9265E-03, 3.8624E-07,
     &                        4.3640E-03,-2.1767E-07,-1.6975E-03,
     &                        1.4715E-08,-6.7945E-02, 6.7140E-07,
     &                       -5.8461E-03, 1.1914E-07, 2.4496E-04,
     &                       -4.9921E-08,-3.8830E-04,-1.2488E-02,
     &                       -3.9557E-07, 9.4377E-04, 1.5100E-07,
     &                        4.1863E-04,-2.6552E-08,-9.4832E-04,
     &                        3.7187E-02, 7.8305E-07,-3.6193E-03,
     &                        1.9130E-07,-5.5284E-04,-7.0234E-08,
     &                       -1.1616E-02, 7.5494E-08, 1.4075E-03,
     &                        7.9285E-08, 3.1501E-04,-3.4879E-08,
     &                        3.8138E-02, 4.5561E-07,-5.2993E-06,
     &                        7.2506E-08,-4.6427E-04, 1.1952E-02,
     &                        1.9508E-07,-7.3901E-04, 1.6083E-08,
     &                        4.6821E-04, 2.2138E-03, 1.9836E-08,
     &                        9.1512E-05, 2.5883E-10, 1.6160E-02,
     &                        9.8914E-08, 2.2891E-04, 3.5686E-08,
     &                       -2.3945E-02,-9.7206E-08, 4.1304E-04,
     &                       -1.1323E-02,-1.0595E-07, 2.4607E-06,
     &                       -1.1919E-02,-1.2954E-07,-1.5160E-02,
     &                       -9.8974E-08, 9.1103E-03,-9.8102E-04/
C     850km June solstice
      DATA (D(3,2,J),J=1,81)/ 3.4298E+00, 2.6491E-02, 1.3842E-01,
     &                        4.0680E-02,-5.6606E-02,-5.7153E-03,
     &                       -1.4690E-02, 7.5677E-03, 3.2216E-04,
     &                       -1.8092E-01, 1.2032E-02, 8.3830E-03,
     &                       -1.6994E-03, 7.3073E-03, 4.6493E-03,
     &                       -5.9776E-03,-1.0911E-03, 1.8614E-02,
     &                       -6.0207E-03,-4.0287E-03,-2.4354E-03,
     &                        3.2668E-03, 2.0486E-03,-2.4568E-03,
     &                        1.7932E-04,-7.2842E-02, 1.2262E-03,
     &                       -2.4092E-03, 2.1826E-03, 1.1999E-03,
     &                       -5.7385E-04,-7.9356E-04,-4.8885E-03,
     &                        6.0397E-03, 1.5036E-03,-6.6850E-04,
     &                       -1.5557E-03, 7.0217E-04,-6.6930E-04,
     &                        2.7146E-02,-1.7554E-04,-5.7637E-03,
     &                       -4.8048E-05, 1.7230E-04, 2.7707E-04,
     &                       -1.8722E-02,-2.5534E-03, 2.7433E-03,
     &                       -9.4675E-04, 3.5885E-04, 1.6066E-04,
     &                        4.7142E-02,-3.8642E-03,-1.8094E-03,
     &                        3.7500E-04,-8.2361E-05, 3.4841E-04,
     &                       -2.1525E-03,-1.6265E-03,-5.6589E-04,
     &                        3.9127E-04, 2.3966E-02, 5.8480E-04,
     &                        1.1863E-05,-4.6920E-04,-3.2951E-03,
     &                       -1.3868E-03,-3.2869E-04,-4.1003E-05,
     &                       -8.5024E-03, 6.8306E-04, 1.2730E-03,
     &                        3.5803E-03,-6.7022E-05,-9.2460E-04,
     &                       -5.0650E-03, 2.3747E-03,-1.1690E-02,
     &                        2.7210E-04,-1.2308E-02,-2.4554E-03/
C     1400km equinox
      DATA (D(4,1,J),J=1,81)/ 3.4323E+00, 5.9891E-08, 1.4440E-01,
     &                       -2.5296E-06,-3.0483E-02, 8.7633E-07,
     &                       -2.0333E-02, 1.4639E-06, 8.3905E-03,
     &                       -2.4661E-01,-3.3357E-07, 2.3371E-02,
     &                       -2.6009E-07, 7.4049E-03,-4.2111E-07,
     &                       -4.0153E-03, 3.2564E-07,-3.3975E-02,
     &                       -3.1496E-07, 5.0539E-04,-2.1844E-07,
     &                        6.6046E-03, 3.7777E-07, 1.0884E-03,
     &                       -1.7690E-07,-9.7080E-02,-1.0183E-06,
     &                        3.2316E-04, 2.3879E-07, 1.0714E-03,
     &                       -1.5921E-07,-2.2353E-04,-7.8730E-02,
     &                       -4.9271E-07,-3.3524E-03,-9.7695E-08,
     &                        4.0369E-06, 9.1746E-08, 4.3697E-04,
     &                        5.4799E-02,-1.5613E-06, 2.0376E-05,
     &                        1.5198E-07, 5.2388E-05,-4.3276E-08,
     &                       -1.9427E-02,-4.8251E-07,-3.6941E-03,
     &                        1.0404E-08,-3.8792E-04, 1.9478E-08,
     &                        2.7545E-02,-7.9193E-07, 1.9158E-05,
     &                       -3.8582E-08, 4.3319E-06, 2.1105E-02,
     &                        5.6969E-08,-1.4642E-03, 1.7346E-08,
     &                       -2.0981E-04,-1.6940E-02,-3.2828E-07,
     &                        9.3221E-04,-5.8952E-08, 2.2700E-02,
     &                        8.6772E-07,-3.0788E-04,-3.1938E-08,
     &                       -3.5342E-02,-4.1651E-08,-4.6744E-04,
     &                        3.2506E-03, 9.8322E-07, 2.4373E-04,
     &                        1.0563E-02,-4.2559E-08,-1.4966E-02,
     &                        6.3242E-07, 3.0936E-02, 5.0785E-04/
C     1400km June solstice
      DATA (D(4,2,J),J=1,81)/ 3.4432E+00, 1.4031E-02, 1.3160E-01,
     &                        2.5090E-02,-4.2982E-02,-4.1350E-03,
     &                       -2.3576E-02, 4.5813E-04, 9.9480E-03,
     &                       -2.4132E-01, 3.9410E-03, 2.5328E-02,
     &                        2.5753E-03, 4.7467E-03, 2.4033E-03,
     &                       -4.5280E-03,-1.6768E-03,-2.4686E-02,
     &                        1.3680E-03, 4.5365E-03,-2.2588E-04,
     &                        4.7237E-03,-3.4808E-03, 1.9872E-03,
     &                        2.0111E-05,-1.0665E-01, 1.2940E-03,
     &                        5.1466E-04, 1.1414E-03,-2.6179E-04,
     &                        1.6622E-03,-2.9043E-04,-4.1638E-02,
     &                        2.5988E-03, 2.4967E-03, 1.1947E-03,
     &                        9.8563E-04,-1.1244E-03, 4.6249E-04,
     &                        2.2485E-02,-1.8404E-03,-2.7030E-03,
     &                       -5.6671E-04, 6.2775E-05, 2.3428E-04,
     &                       -1.9091E-02, 3.9310E-03,-1.3812E-03,
     &                        6.2219E-04, 4.0298E-04,-2.5167E-04,
     &                        3.6186E-02,-1.6894E-03,-9.2292E-04,
     &                       -3.5095E-04,-1.6027E-05, 5.0279E-03,
     &                        1.6496E-03,-1.2996E-03, 1.0942E-04,
     &                       -8.8813E-05,-9.8253E-04, 6.0205E-05,
     &                        3.1574E-04,-2.5650E-04, 1.6418E-02,
     &                       -7.4029E-04, 8.5019E-05, 7.1348E-05,
     &                       -8.8478E-03, 7.9330E-04, 4.9878E-04,
     &                        6.8566E-03,-1.3812E-03, 3.7630E-04,
     &                       -4.2406E-04,-4.0773E-05,-7.0264E-03,
     &                       -4.8997E-04, 3.2745E-03,-4.3985E-03/
C     2000km equinox
      DATA (D(5,1,J),J=1,81)/ 3.5267E+00, 3.1496E-06, 1.0072E-01,
     &                       -4.0719E-06,-2.9570E-02, 3.1967E-06,
     &                       -1.6759E-02,-2.2291E-06, 1.4529E-02,
     &                       -2.0303E-01, 2.6118E-06, 2.3639E-02,
     &                       -1.5963E-06, 2.8544E-03, 6.3910E-07,
     &                       -6.4201E-03,-1.4241E-07,-2.2074E-02,
     &                        1.3024E-07,-6.5225E-04,-7.5969E-09,
     &                        6.8229E-03,-1.1600E-08, 6.5430E-04,
     &                       -3.1299E-09,-8.9155E-02, 1.0420E-06,
     &                        2.2701E-04,-2.8037E-07, 7.6229E-05,
     &                        9.0789E-08,-8.3574E-04,-4.3006E-02,
     &                        9.5987E-08,-2.5486E-03, 1.2764E-08,
     &                        1.6634E-03,-9.8076E-09,-2.0750E-05,
     &                        4.1638E-02, 1.2831E-07, 3.2205E-03,
     &                       -7.2843E-08, 4.7908E-04, 1.0592E-09,
     &                       -8.8335E-03,-8.6869E-08,-2.5895E-03,
     &                        8.5979E-09, 8.1594E-04, 4.8263E-09,
     &                        4.4205E-02,-4.5836E-08, 2.4211E-03,
     &                       -1.7175E-08, 1.3454E-04, 2.9288E-02,
     &                       -6.4336E-08,-4.7940E-04,-1.7677E-08,
     &                        2.7104E-04, 3.8585E-03,-1.9495E-08,
     &                        9.5007E-04, 1.4881E-10, 3.5952E-02,
     &                        1.2439E-07,-2.6259E-04,-3.3433E-08,
     &                       -4.5002E-03,-9.7622E-08, 1.0627E-04,
     &                        1.7064E-02, 2.6949E-07, 3.5386E-05,
     &                        1.3508E-03,-9.3600E-08, 2.2163E-03,
     &                        1.8302E-07, 1.4533E-02, 6.8208E-03/
C     2000km June solstice
      DATA (D(5,2,J),J=1,81)/ 3.5455E+00, 2.3030E-02, 9.1028E-02,
     &                        5.6686E-03,-4.3555E-02, 7.5223E-03,
     &                       -5.3314E-03,-2.3664E-03, 9.2735E-03,
     &                       -1.7562E-01, 6.8722E-03, 2.6142E-02,
     &                       -7.5933E-03,-2.6850E-03, 1.5072E-03,
     &                       -3.8334E-03,-1.8455E-03,-8.3019E-03,
     &                       -3.1750E-03,-3.4582E-03,-3.0116E-03,
     &                        6.4951E-03,-1.9833E-04, 1.9620E-03,
     &                       -1.6688E-03,-9.1850E-02, 2.8064E-03,
     &                        1.1347E-03, 5.5757E-04,-1.7941E-03,
     &                        4.4038E-04,-7.6030E-04,-1.7519E-02,
     &                        5.5593E-03,-4.0485E-04, 1.0403E-04,
     &                        9.7795E-05,-4.4813E-04, 1.0662E-04,
     &                       -4.4894E-03,-4.3003E-03,-1.3180E-03,
     &                        1.2638E-03,-2.0937E-04,-1.0982E-04,
     &                       -2.8474E-02, 5.8161E-03,-5.9371E-04,
     &                        1.4721E-03,-1.8707E-04, 6.4902E-05,
     &                        6.2783E-03,-1.3854E-03, 2.9896E-04,
     &                       -7.7301E-04,-1.6992E-05,-2.8036E-02,
     &                        1.9110E-03,-1.7128E-04, 6.0156E-04,
     &                       -1.7487E-04, 2.9229E-03,-1.4161E-03,
     &                        5.1841E-04,-8.2856E-05,-1.0698E-02,
     &                       -4.2081E-03,-4.5016E-04, 5.1778E-07,
     &                        1.4779E-02, 5.7698E-04,-3.6797E-04,
     &                       -4.7711E-03,-1.6291E-03,-4.5695E-04,
     &                        1.1890E-02,-1.6669E-04,-5.5450E-03,
     &                       -1.0370E-03,-4.2745E-03, 1.8717E-03/
      DO 10 I=1,81
       D(1,3,I)=D(1,2,I)*MIRREQ(I)
       D(2,3,I)=D(2,2,I)*MIRREQ(I)
       D(3,3,I)=D(3,2,I)*MIRREQ(I)
       D(4,3,I)=D(4,2,I)*MIRREQ(I)
10     D(5,3,I)=D(5,2,I)*MIRREQ(I)
      DO 40 K=1,81
       DO 30 J=1,3
        DO 20 I=1,5 
         DOUT(I,J,K)=D(I,J,K)
20      CONTINUE
30     CONTINUE
40    CONTINUE
C////////////////////////////////////////////////////////////////////////////////////
      RETURN
      END
C
C
      SUBROUTINE KOF107(MIRREQ,DOUT)
C------------------------------------------------------------------------------------
C   coefficients - F107 model part
C------------------------------------------------------------------------------------
      REAL DOUT(5,3,81)
      INTEGER MIRREQ(81),I,J,K
      REAL DPF107(5,3,81)
C     350km equinox
      DATA (DPF107(1,1,J),J=1,81)/ 2.1179E+00, 2.6093E-07, 4.4282E-02,
     &                            -1.3876E-06, 2.7803E-02, 1.3986E-06,
     &                             2.9846E-02, 5.5440E-07, 1.3094E-02,
     &                            -2.5151E-02,-1.0646E-07,-3.7429E-03,
     &                             1.6883E-08,-8.7810E-05, 2.4570E-08,
     &                             5.3157E-04, 2.4498E-09,-7.4921E-03,
     &                             3.4559E-07, 2.7384E-03,-2.9301E-07,
     &                            -6.4160E-03,-2.9594E-08,-1.2326E-03,
     &                             2.0038E-07, 1.4916E-01, 8.9752E-08,
     &                             1.7673E-02,-3.3613E-08, 3.8401E-03,
     &                             5.1558E-08, 4.3661E-05,-1.3354E-01,
     &                            -4.2996E-08,-1.6325E-02,-5.9756E-08,
     &                            -7.8924E-04, 9.0574E-09, 9.4891E-05,
     &                            -4.6522E-02, 1.6467E-07, 3.0933E-03,
     &                            -2.4212E-08,-8.5264E-04,-2.8060E-09,
     &                             2.0465E-02, 3.9607E-08, 2.4059E-03,
     &                             2.3086E-08,-9.3343E-04, 2.1124E-08,
     &                             3.5658E-02,-4.9285E-08,-9.9046E-04,
     &                            -2.8411E-08, 4.9889E-04,-2.0836E-02,
     &                             2.7124E-07, 3.9610E-03,-5.1577E-08,
     &                             1.2194E-03, 2.0681E-02, 2.2079E-08,
     &                            -1.5148E-03,-1.4727E-08, 2.9282E-02,
     &                            -7.1036E-08,-1.0708E-03,-7.0356E-09,
     &                             3.5476E-02, 1.4627E-08, 1.6406E-03,
     &                             2.0173E-02, 1.1973E-07, 5.7493E-06,
     &                             9.8510E-04,-5.6858E-08,-6.9055E-03,
     &                             8.8015E-08,-5.2797E-03, 4.9785E-02/
C     350km June solstice
      DATA (DPF107(1,2,J),J=1,81)/ 2.1118E+00, 1.2667E-02, 7.8532E-02,
     &                             2.8013E-03, 4.6247E-03,-1.8002E-02,
     &                             1.7402E-02, 2.1645E-02, 9.7880E-04,
     &                             1.6106E-03, 1.5252E-02, 4.2830E-04,
     &                             2.2738E-03, 5.1962E-03,-1.2009E-03,
     &                            -2.4580E-03, 1.1339E-03, 2.4005E-03,
     &                            -9.1238E-03,-6.2242E-03, 7.1732E-04,
     &                             4.7369E-03,-2.0235E-03,-2.8728E-03,
     &                             1.5519E-03,-1.5735E-01, 5.1640E-03,
     &                            -1.0377E-02, 1.5376E-03,-1.2147E-04,
     &                             1.1153E-03,-4.0444E-04, 6.2152E-02,
     &                             4.3814E-03, 8.5715E-03,-1.1794E-03,
     &                            -1.4507E-03,-2.9136E-04, 4.8678E-05,
     &                            -2.5783E-02,-6.4352E-03, 2.8888E-03,
     &                            -2.3923E-04,-7.8468E-04, 1.0567E-04,
     &                             1.8717E-02,-3.7789E-03, 1.9293E-03,
     &                             2.7927E-03, 6.1046E-04,-6.4161E-04,
     &                             2.9512E-02, 1.8061E-03,-6.0273E-04,
     &                            -1.4189E-03,-1.2866E-04, 3.4173E-02,
     &                             7.0098E-03, 2.7884E-03, 1.3619E-03,
     &                             1.0141E-03, 4.4472E-02,-3.6668E-03,
     &                            -6.6634E-04,-9.1539E-04,-4.3310E-02,
     &                             4.6828E-03,-1.0213E-03, 9.6850E-04,
     &                            -8.9240E-04, 3.0694E-03, 1.1888E-03,
     &                            -3.2205E-02, 2.4068E-04, 1.5491E-03,
     &                            -1.3486E-03, 1.5805E-03, 1.2679E-02,
     &                             1.5963E-03,-9.2296E-03, 3.3470E-02/
C     550km equinox
      DATA (DPF107(2,1,J),J=1,81)/ 2.2596E+00,-1.0250E-06,-6.0469E-02,
     &                            -5.1717E-08, 2.4081E-02, 1.3561E-06,
     &                             2.2501E-02, 1.8975E-07,-1.9328E-03,
     &                             1.8631E-03,-6.9838E-08, 8.5643E-03,
     &                             2.2625E-07,-9.6354E-04, 1.4344E-07,
     &                            -9.9794E-04,-1.4888E-07,-2.1439E-02,
     &                             1.6757E-07, 2.2087E-02, 1.9753E-07,
     &                             3.3401E-03, 1.7510E-08,-4.4513E-03,
     &                            -1.9434E-07, 2.1312E-02, 4.1158E-07,
     &                             4.1293E-03, 1.2532E-07, 1.6378E-03,
     &                            -6.0591E-08, 3.8969E-04,-8.2128E-04,
     &                            -3.7332E-07,-9.0674E-03,-1.6562E-07,
     &                            -6.4580E-04,-2.4214E-08, 1.7187E-04,
     &                            -7.8323E-03,-3.4188E-09,-3.3704E-03,
     &                            -3.7064E-08,-8.1990E-04,-3.4103E-08,
     &                             2.8832E-04,-1.3091E-07, 5.9580E-04,
     &                             3.5007E-09,-2.4893E-05, 3.7407E-08,
     &                             9.8550E-03, 5.2340E-08, 2.4715E-03,
     &                            -2.2799E-09, 6.0276E-04,-2.3370E-03,
     &                             1.5897E-07,-7.8384E-04, 6.2186E-08,
     &                             1.5512E-04, 1.0034E-03, 6.2956E-08,
     &                             1.2935E-03, 1.1142E-08,-5.6848E-03,
     &                             5.7028E-08,-1.1159E-03, 5.2481E-09,
     &                            -6.4583E-04,-4.9024E-08,-8.7256E-05,
     &                            -3.6805E-03,-4.2162E-11, 5.9164E-04,
     &                            -1.1688E-03,-6.3884E-09,-3.4464E-03,
     &                            -2.9236E-08,-3.2531E-03, 7.3254E-04/
C     550km June solstice
      DATA (DPF107(2,2,J),J=1,81)/ 2.2443E+00,-7.5467E-03, 4.6154E-03,
     &                            -3.2706E-02,-9.4369E-03,-2.9842E-03,
     &                             9.5202E-03, 2.6462E-02, 8.1390E-03,
     &                             2.2865E-03,-8.1542E-03, 1.1328E-03,
     &                            -4.8105E-03, 1.5307E-03, 1.8632E-03,
     &                             1.1856E-03, 9.7583E-04,-1.4236E-03,
     &                             1.0665E-02, 1.1196E-02, 1.0141E-02,
     &                             2.7029E-03, 7.6283E-04,-2.2904E-04,
     &                            -7.3431E-04,-6.9053E-03, 2.8684E-04,
     &                             8.7857E-04, 8.9792E-04, 1.8426E-03,
     &                             1.0182E-05, 9.9144E-04,-6.8376E-03,
     &                             4.1889E-03,-8.3520E-04, 4.7692E-03,
     &                            -2.1779E-04,-3.2160E-04,-2.3404E-04,
     &                            -3.9832E-03,-8.0937E-04,-2.5324E-03,
     &                            -1.1029E-04,-3.9410E-04,-2.9127E-04,
     &                             1.4673E-02, 1.4644E-03, 4.4913E-03,
     &                             1.2082E-03, 1.1461E-03, 9.7184E-04,
     &                             8.7871E-03, 2.9808E-05, 2.7913E-03,
     &                             7.6192E-04, 9.4134E-04, 5.0748E-04,
     &                             3.2757E-03, 1.3459E-03, 7.4301E-04,
     &                             5.2271E-05,-1.1622E-03, 2.0424E-03,
     &                             7.4028E-04, 3.1044E-04,-7.8888E-04,
     &                             7.3294E-04, 4.5496E-04, 3.7781E-04,
     &                            -6.7759E-03,-1.3669E-03, 2.5073E-04,
     &                             7.8526E-03, 2.1084E-04,-6.8010E-06,
     &                            -1.2768E-04, 9.3358E-05, 5.0014E-03,
     &                             5.5091E-04, 6.4201E-04, 2.6821E-03/
C     850km equinox
      DATA (DPF107(3,1,J),J=1,81)/ 2.2430E+00, 6.3529E-07,-2.1093E-02,
     &                             2.3192E-06, 3.9848E-03,-4.0399E-06,
     &                            -2.0864E-03, 1.4147E-06,-2.7632E-03,
     &                             3.8821E-03, 4.3770E-07,-6.7410E-04,
     &                             3.7620E-07, 2.5406E-04,-5.5479E-07,
     &                             4.2678E-04, 3.7791E-07,-2.1396E-03,
     &                             4.3688E-07,-1.3975E-04, 5.5689E-08,
     &                            -7.7591E-04,-2.3032E-07,-7.6251E-06,
     &                             1.1410E-07, 3.5107E-02, 3.3463E-07,
     &                             5.8991E-03,-1.6889E-07, 6.4584E-04,
     &                             1.6902E-07, 1.7415E-04, 7.1402E-03,
     &                             4.6111E-07,-6.6733E-04, 1.5319E-07,
     &                            -2.8179E-04,-4.4107E-08, 1.8358E-04,
     &                             3.9796E-03,-4.7690E-08,-2.6286E-04,
     &                            -1.6931E-07, 5.3136E-05, 4.6929E-08,
     &                             4.6506E-06, 1.0615E-07,-2.2795E-04,
     &                            -1.9598E-08,-3.4348E-05,-1.8839E-08,
     &                            -6.1345E-03,-1.5260E-08, 5.7992E-04,
     &                            -7.6335E-08, 2.2449E-04, 4.1926E-03,
     &                             4.8940E-08, 1.2125E-03,-7.3629E-08,
     &                             3.8057E-04, 1.9487E-03,-1.6906E-09,
     &                             2.1031E-04,-8.3425E-09,-2.3397E-03,
     &                             3.7214E-08,-2.0578E-04,-7.7983E-08,
     &                             1.9869E-02,-1.5178E-07, 7.1451E-05,
     &                            -1.6288E-02,-2.8123E-08,-6.2559E-04,
     &                             1.6419E-04,-8.6871E-08,-3.8220E-03,
     &                            -3.4288E-08,-1.6062E-02,-2.3689E-03/
C     850km June solstice
      DATA (DPF107(3,2,J),J=1,81)/ 2.2234E+00, 8.7471E-03,-3.6271E-02,
     &                            -1.8205E-02, 1.4310E-02, 1.4137E-02,
     &                             1.1152E-03,-5.6408E-03,-2.3086E-04,
     &                             9.8994E-03, 3.6786E-04,-7.5900E-03,
     &                             3.6605E-03, 4.2347E-03, 9.9788E-04,
     &                            -1.0637E-03, 6.0786E-05, 3.3041E-03,
     &                             3.2600E-03,-3.9354E-03,-1.1438E-04,
     &                             2.8440E-03, 6.3044E-04,-1.1396E-03,
     &                             1.1203E-04, 3.9674E-02, 1.7704E-03,
     &                            -1.3756E-03,-2.0221E-04,-5.5309E-04,
     &                             2.5297E-04, 2.3301E-04, 2.1051E-02,
     &                             8.2900E-03,-9.2282E-04,-2.2149E-03,
     &                            -1.2940E-03, 5.0482E-04, 3.2355E-04,
     &                             3.3826E-03,-6.9424E-03, 4.4450E-04,
     &                             3.5048E-04,-2.8501E-04, 8.5714E-05,
     &                             5.0172E-05,-6.0011E-03,-1.9778E-03,
     &                             7.9132E-04, 4.8467E-04,-8.8136E-06,
     &                             5.5216E-03,-3.1276E-03,-1.6523E-03,
     &                             2.7189E-04, 1.2939E-04, 1.6626E-02,
     &                            -3.9681E-04, 3.1331E-03, 1.1602E-05,
     &                            -2.8408E-04, 1.3352E-02, 2.8371E-03,
     &                             4.9534E-04,-1.7470E-04,-6.1464E-04,
     &                            -7.3693E-03,-2.1311E-04, 8.8980E-05,
     &                             2.0388E-02, 2.5072E-04,-1.3785E-03,
     &                            -2.1501E-02,-2.0520E-03, 3.9847E-04,
     &                            -9.8123E-04, 3.0419E-03, 6.5642E-03,
     &                            -1.3463E-03,-4.1453E-03,-3.4043E-03/
C     1400km equinox
      DATA (DPF107(4,1,J),J=1,81)/ 2.0721E+00,-1.2810E-06,-2.2446E-02,
     &                             4.0113E-06, 1.5405E-02,-4.0985E-06,
     &                            -4.4873E-03, 1.6972E-06, 1.0420E-03,
     &                            -1.0762E-03, 4.3349E-08, 1.2188E-03,
     &                             2.3954E-08,-2.0416E-03,-2.3801E-08,
     &                             2.9302E-04,-2.3188E-08,-7.1780E-04,
     &                            -1.8559E-08,-2.6530E-03,-9.1704E-08,
     &                             1.9664E-03, 7.4905E-08, 9.7068E-06,
     &                             3.6472E-08, 9.6520E-03,-1.1466E-06,
     &                            -5.4198E-03, 4.4641E-07,-1.3638E-04,
     &                            -8.7144E-08, 4.4808E-05,-3.3499E-02,
     &                             1.2687E-06, 2.7432E-03,-6.2446E-07,
     &                            -4.9937E-04, 1.3601E-07,-1.1713E-04,
     &                             7.6744E-03,-2.2096E-08,-5.5947E-05,
     &                            -3.6655E-08,-2.3160E-04, 1.5485E-09,
     &                             1.9511E-03, 3.2565E-08,-5.0748E-04,
     &                            -2.2702E-08, 2.1519E-04, 4.2344E-09,
     &                            -2.4070E-02, 4.2536E-08,-1.0566E-03,
     &                            -4.8657E-08,-2.4020E-05,-5.3805E-02,
     &                             1.2672E-06, 1.9215E-03,-1.5258E-07,
     &                             1.4154E-04,-3.3868E-03, 4.4217E-08,
     &                            -6.1293E-04,-1.1966E-08,-7.1448E-03,
     &                            -1.3842E-08,-4.8955E-04, 1.9888E-08,
     &                            -5.3833E-02, 5.0588E-07, 1.7924E-04,
     &                            -1.0013E-02, 4.5334E-07, 4.6489E-04,
     &                            -1.7219E-05, 2.8226E-08, 1.2155E-03,
     &                            -5.5547E-08,-2.5776E-02, 3.7582E-02/
C     1400km June solstice
      DATA (DPF107(4,2,J),J=1,81)/ 2.0715E+00, 1.1060E-02,-7.2558E-03,
     &                             1.6759E-02, 4.4526E-03,-3.1949E-03,
     &                            -1.1849E-03, 1.9253E-03, 1.6289E-03,
     &                             2.1829E-04,-3.3721E-03, 2.6217E-03,
     &                             7.8261E-04, 5.2241E-04,-1.0364E-03,
     &                             1.4120E-05,-1.7664E-04, 2.6144E-03,
     &                             4.9622E-04,-1.1139E-03, 2.5938E-03,
     &                            -1.3858E-03,-4.7107E-04,-2.2748E-04,
     &                            -6.5263E-04, 1.5465E-04,-1.8961E-04,
     &                             1.9626E-03,-1.3251E-03,-3.5464E-04,
     &                            -3.6056E-04, 7.2928E-04,-3.4355E-02,
     &                            -5.4377E-04,-3.7358E-04,-5.4676E-04,
     &                            -6.0062E-04,-8.5823E-05,-4.2649E-04,
     &                            -2.5657E-03, 2.0810E-03,-5.0775E-04,
     &                            -6.9662E-05,-1.1269E-04,-2.9248E-05,
     &                            -4.2538E-04, 3.1001E-03, 9.3147E-05,
     &                            -2.0474E-04, 9.2787E-05, 1.5224E-04,
     &                             1.6699E-02,-1.0915E-03, 3.9374E-04,
     &                             6.2488E-05, 5.3697E-05, 4.2104E-03,
     &                             2.6857E-04,-5.6046E-04,-1.7589E-04,
     &                            -1.6645E-04,-1.0895E-03, 3.1274E-04,
     &                            -7.0907E-05,-1.8092E-04,-3.0431E-03,
     &                            -4.6234E-04,-2.6949E-05,-3.1150E-06,
     &                             4.6148E-03,-3.4373E-04, 9.9880E-04,
     &                            -2.2815E-03, 3.8619E-04,-8.9996E-05,
     &                            -2.2212E-05, 2.8260E-04, 3.3863E-03,
     &                            -6.4781E-04, 1.0682E-02,-5.7521E-03/
C     2000km equinox
      DATA (DPF107(5,1,J),J=1,81)/ 2.2225E+00,-1.8465E-07, 3.9702E-02,
     &                             7.4498E-08, 6.7294E-03,-1.5623E-07,
     &                             8.6264E-04, 4.9782E-07,-1.0457E-02,
     &                            -1.7603E-02,-4.2609E-07, 1.1957E-02,
     &                             2.8967E-07, 4.0676E-03,-4.8392E-08,
     &                            -2.0672E-03,-2.7825E-08, 2.3117E-02,
     &                            -8.1847E-07, 6.3865E-04, 1.2350E-07,
     &                            -3.1363E-03, 2.3973E-08, 7.4011E-04,
     &                             2.2201E-08, 1.5339E-02,-9.2354E-07,
     &                            -5.0780E-04, 2.4487E-07,-1.4002E-03,
     &                            -9.5180E-08,-2.2099E-04,-2.6709E-02,
     &                             2.0174E-07, 5.2254E-03,-6.4659E-08,
     &                            -4.5011E-04,-1.3226E-08,-5.0770E-04,
     &                             2.3246E-02, 4.0279E-07, 4.2692E-03,
     &                            -8.2578E-08, 2.8635E-04, 1.9589E-08,
     &                             6.1547E-04,-1.6112E-07,-3.4024E-03,
     &                            -3.3185E-08,-8.0475E-04, 6.1774E-09,
     &                             3.9677E-02, 1.8432E-07, 2.2421E-03,
     &                            -3.3228E-09,-2.2705E-05,-2.1308E-02,
     &                            -1.1246E-07, 2.6961E-03, 2.2048E-08,
     &                             1.6385E-05, 1.0901E-02, 4.6221E-07,
     &                            -3.8862E-06,-4.9407E-08, 1.3349E-02,
     &                             9.8339E-08,-5.5719E-04,-1.8928E-08,
     &                             3.9061E-02, 4.3038E-07, 1.0085E-03,
     &                             1.1895E-02, 4.6967E-07, 4.3363E-04,
     &                            -5.3628E-03, 4.2370E-07, 1.2707E-03,
     &                             1.0193E-07, 1.2395E-02, 1.0030E-02/
C     2000km June solstice
      DATA (DPF107(5,2,J),J=1,81)/ 2.2631E+00, 2.1866E-02, 4.6921E-03,
     &                            -3.3329E-02, 1.0108E-02,-1.2195E-02,
     &                             4.8366E-03, 2.1350E-02,-8.6916E-03,
     &                             3.4443E-03,-7.1057E-03,-1.4225E-03,
     &                            -9.9691E-03,-6.0693E-04,-2.9332E-03,
     &                            -1.0505E-03,-1.9665E-03, 2.1469E-02,
     &                            -1.9500E-02,-1.0986E-02, 5.2916E-03,
     &                             2.7388E-03,-4.6114E-05,-2.6742E-03,
     &                             2.0601E-06, 7.5298E-03,-1.1021E-02,
     &                            -3.8100E-03,-1.2864E-03,-1.0705E-03,
     &                            -4.8383E-04,-1.2329E-03, 3.4064E-02,
     &                            -1.6264E-02, 2.6406E-04, 1.1486E-03,
     &                             2.0181E-03, 4.7744E-04,-2.2118E-04,
     &                             8.5559E-03, 4.6544E-03,-3.0707E-03,
     &                             1.0697E-03, 7.4102E-05,-6.8598E-04,
     &                            -3.7443E-02,-4.1490E-03, 4.8394E-03,
     &                             2.8449E-04,-8.1610E-04, 4.1996E-04,
     &                            -2.3120E-02,-2.2430E-03,-1.6598E-03,
     &                             5.4323E-04,-3.9800E-04, 8.7947E-03,
     &                             5.9441E-03, 1.2565E-04, 8.0901E-04,
     &                            -7.3510E-04,-2.1540E-02,-2.6029E-04,
     &                             1.1616E-03,-1.5312E-04, 6.3625E-03,
     &                            -4.0037E-03,-1.5571E-03,-5.7964E-04,
     &                             8.1764E-03,-2.3762E-05,-1.2959E-04,
     &                             6.2361E-03,-4.9235E-03, 6.0991E-04,
     &                             1.6101E-03,-3.9088E-03,-1.3380E-02,
     &                            -4.2837E-04,-1.1667E-02, 3.9335E-03/
      DO 10 I=1,81
       DPF107(1,3,I)=DPF107(1,2,I)*MIRREQ(I)
       DPF107(2,3,I)=DPF107(2,2,I)*MIRREQ(I)
       DPF107(3,3,I)=DPF107(3,2,I)*MIRREQ(I)
       DPF107(4,3,I)=DPF107(4,2,I)*MIRREQ(I)
10     DPF107(5,3,I)=DPF107(5,2,I)*MIRREQ(I)
      DO 40 K=1,81
       DO 30 J=1,3
        DO 20 I=1,5 
         DOUT(I,J,K)=DPF107(I,J,K)
20      CONTINUE
30     CONTINUE
40    CONTINUE
C////////////////////////////////////////////////////////////////////////////////////
      RETURN
      END
C     
C
      SUBROUTINE locate(xx,n,x,j)
C------------------------------------------------------------------------------------
      INTEGER j,n
      REAL x,xx(n)
      INTEGER jl,jm,ju
      jl=0
      ju=n+1
10    if(ju-jl.gt.1)then
        jm=(ju+jl)/2
        if((xx(n).gt.xx(1)).eqv.(x.gt.xx(jm)))then
          jl=jm
        else
          ju=jm
        endif
      goto 10
      endif
      j=jl
      return
      END
C
C
        SUBROUTINE SPHARM_IK(C,L,M,COLAT,AZ)
C------------------------------------------------------------------------------------
C CALCULATES THE COEFFICIENTS OF THE SPHERICAL HARMONIC
C FROM IRI 95 MODEL
C NOTE: COEFFICIENTS CORRESPONDING TO COS, SIN SWAPPED!!!
C------------------------------------------------------------------------------------
      DIMENSION C(82)
      C(1)=1.
      K=2
      X=COS(COLAT)
      C(K)=X
      K=K+1
      DO 10 I=2,L
      C(K)=((2*I-1)*X*C(K-1)-(I-1)*C(K-2))/I
10    K=K+1
      Y=SIN(COLAT)
      DO 20 MT=1,M
      CAZ=COS(MT*AZ)
      SAZ=SIN(MT*AZ)
      C(K)=Y**MT
      K=K+1
      IF(MT.EQ.L) GOTO 16
      C(K)=C(K-1)*X*(2*MT+1)
      K=K+1
      IF((MT+1).EQ.L) GOTO 16
      DO 15 I=2+MT,L
      C(K)=((2*I-1)*X*C(K-1)-(I+MT-1)*C(K-2))/(I-MT)
15    K=K+1
16    N=L-MT+1
      DO 18 I=1,N
      C(K)=C(K-N)*SAZ
      C(K-N)=C(K-N)*CAZ
18    K=K+1
20    CONTINUE
      RETURN
      END
C     
C
      SUBROUTINE spline(x,y,n,yp1,ypn,y2)
C------------------------------------------------------------------------------------
      INTEGER n,NMAX
      REAL yp1,ypn,x(n),y(n),y2(n)
      PARAMETER (NMAX=500)
      INTEGER i,k
      REAL p,qn,sig,un,u(NMAX)
      if (yp1.gt..99e30) then
        y2(1)=0.
        u(1)=0.
      else
        y2(1)=-0.5
        u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
      endif
      do 11 i=2,n-1
        sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
        p=sig*y2(i-1)+2.
        y2(i)=(sig-1.)/p
        u(i)=(6.*((y(i+1)-y(i))/(x(i+
     *1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*
     *u(i-1))/p
11    continue
      if (ypn.gt..99e30) then
        qn=0.
        un=0.
      else
        qn=0.5
        un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
      endif
      y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
      do 12 k=n-1,1,-1
        y2(k)=y2(k)*y2(k+1)+u(k)
12    continue
      return
      END
C
C
      SUBROUTINE splint(xa,ya,y2a,n,x,y)
C------------------------------------------------------------------------------------
      INTEGER n
      REAL x,y,xa(n),y2a(n),ya(n)
      INTEGER k,khi,klo
      REAL a,b,h
      klo=1
      khi=n
1     if (khi-klo.gt.1) then
        k=(khi+klo)/2
        if(xa(k).gt.x)then
          khi=k
        else
          klo=k
        endif
      goto 1
      endif
      h=xa(khi)-xa(klo)
      a=(xa(khi)-x)/h
      b=(x-xa(klo))/h
      y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**
     *2)/6.
      return
      END
C
C
       SUBROUTINE SWAPEL(N,A)
C------------------------------------------------------------------------------------
C      swaps elements of array
C------------------------------------------------------------------------------------
       INTEGER N,I  
       REAL A(N),AT(N)
       DO 10 I=1,N
10      AT(I)=A(I) 
       DO 20 I=0,N-1
20      A(I+1)=AT(N-I)                   
       RETURN
       END
C
C
       SUBROUTINE TEDIFI(F107IN,TEXN,TEDN,F107DF,TEDIF)
C------------------------------------------------------------------------------------
C      interpolation for solar activity        
C------------------------------------------------------------------------------------
       REAL F107IN,TEXN,TEDN,F107DF(3),TEDIF
       REAL T0DNXN(3),T0DN(2),TDNXN(2)
       REAL INTERP
       IF ((F107IN .GE. F107DF(1)) .AND. (F107IN .LE. F107DF(3))) THEN
        T0DNXN(1)=0.
        T0DNXN(2)=TEDN
        T0DNXN(3)=TEXN
        TEDIF=INTERP(3,2,T0DNXN,F107DF,F107IN)
       END IF    
       IF (F107IN .LT. F107DF(1)) THEN
        T0DN(1)=0.
        T0DN(2)=TEDN
        TEDIF=INTERP(2,1,T0DN,F107DF(1),F107IN)     
       END IF 
       IF (F107IN .GT. F107DF(3)) THEN
        TDNXN(1)=TEDN
        TDNXN(2)=TEXN
        TEDIF=INTERP(2,1,TDNXN,F107DF(2),F107IN)     
       END IF        
       RETURN
       END
C
C
       SUBROUTINE TPCAS(MLTRAD,PF107,PF107M,
     &                  XNDI,DNDI,PD,XNNI,DNNI,PN,TPASEA)
C------------------------------------------------------------------------------------
C      correction for season at fixed altitude
C------------------------------------------------------------------------------------
       REAL MLTRAD,PF107,PF107M,XNDI,DNDI,PD(3),XNNI,DNNI,PN(3),TPASEA
       REAL TA,TM,TDC,TNC
       CALL TEDIFI(PF107,XNDI,DNDI,PD,TA)
       CALL TEDIFI(PF107M,XNDI,DNDI,PD,TM)  
       TDC=TA-TM
        TDC=AMAX1(TDC,-1250.)
        TDC=AMIN1(TDC,1250.)
       CALL TEDIFI(PF107,XNNI,DNNI,PN,TA)
       CALL TEDIFI(PF107M,XNNI,DNNI,PN,TM)         
       TNC=TA-TM
        TNC=AMAX1(TNC,-1250.)
        TNC=AMIN1(TNC,1250.)       
C      harmonic interpolation for local time       
       TPASEA=(1.-COS(MLTRAD))/2.*(TDC-TNC)+TNC
       RETURN
       END

C
C
      SUBROUTINE   TPCORR(INVDIP,MLT,DDD,PF107,
     &             P350A,P350B,P550A,P550B,P850A,P850B,
     &             P1400A,P1400B,P2000A,P2000B, 
     &             TP350A,TP350B,TP550A,TP550B,TP850A,TP850B,
     &             TP140A,TP140B,TP200A,TP200B)
C------------------------------------------------------------------------------------
       REAL INVDIP,MLT,PF107
       INTEGER DDD
       REAL        P350A,P350B,P550A,P550B,P850A,P850B,
     &             P1400A,P1400B,P2000A,P2000B, 
     &             TP350A,TP350B,TP550A,TP550B,TP850A,TP850B,
     &             TP140A,TP140B,TP200A,TP200B
       REAL INTERP
       REAL MLTRAD
C      Constants    
       REAL INVDPQ(13)
C      PF107 Day Equinox       
       REAL P2DE(13,3),P1DE(13,3),P8DE(13,3),P5DE(13,3),P3DE(13,3)
C      Te max-min dif Day Equinox       
       REAL CXN2DE(13),CXN1DE(13),CXN8DE(13),CXN5DE(13),CXN3DE(13)
C      Te med-min dif Day Equinox       
       REAL CDN2DE(13),CDN1DE(13),CDN8DE(13),CDN5DE(13),CDN3DE(13)
C
C      PF107 Night Equinox       
       REAL P2NE(13,3),P1NE(13,3),P8NE(13,3),P5NE(13,3),P3NE(13,3)
C      Te max-min dif Night Equinox       
       REAL CXN2NE(13),CXN1NE(13),CXN8NE(13),CXN5NE(13),CXN3NE(13)
C      Te med-min dif Night Equinox       
       REAL CDN2NE(13),CDN1NE(13),CDN8NE(13),CDN5NE(13),CDN3NE(13)
C       
C
C      PF107 Day Solstice       
       REAL P2DS(13,3),P1DS(13,3),P8DS(13,3),P5DS(13,3),P3DS(13,3)
C      Te max-min dif Day Solstice       
       REAL CXN2DS(13),CXN1DS(13),CXN8DS(13),CXN5DS(13),CXN3DS(13)
C      Te med-min dif Day Solstice       
       REAL CDN2DS(13),CDN1DS(13),CDN8DS(13),CDN5DS(13),CDN3DS(13)
C
C      PF107 Night Solstice       
       REAL P2NS(13,3),P1NS(13,3),P8NS(13,3),P5NS(13,3),P3NS(13,3)
C      Te max-min dif Night Solstice       
       REAL CXN2NS(13),CXN1NS(13),CXN8NS(13),CXN5NS(13),CXN3NS(13)
C      Te med-min dif Night Solstice       
       REAL CDN2NS(13),CDN1NS(13),CDN8NS(13),CDN5NS(13),CDN3NS(13)
C      working variables
       REAL TXN2DE(13),TXN1DE(13),TXN8DE(13),TXN5DE(13),TXN3DE(13)
       REAL TDN2DE(13),TDN1DE(13),TDN8DE(13),TDN5DE(13),TDN3DE(13)
       REAL TXN2NE(13),TXN1NE(13),TXN8NE(13),TXN5NE(13),TXN3NE(13)
       REAL TDN2NE(13),TDN1NE(13),TDN8NE(13),TDN5NE(13),TDN3NE(13)
       REAL TXN2DS(13),TXN1DS(13),TXN8DS(13),TXN5DS(13),TXN3DS(13)
       REAL TDN2DS(13),TDN1DS(13),TDN8DS(13),TDN5DS(13),TDN3DS(13)
       REAL TXN2NS(13),TXN1NS(13),TXN8NS(13),TXN5NS(13),TXN3NS(13)
       REAL TDN2NS(13),TDN1NS(13),TDN8NS(13),TDN5NS(13),TDN3NS(13)      
C
C      Interpolated PF107
       REAL P2DEI(3),P1DEI(3),P8DEI(3),P5DEI(3),P3DEI(3)
       REAL P2NEI(3),P1NEI(3),P8NEI(3),P5NEI(3),P3NEI(3)
       REAL P2DSI(3),P1DSI(3),P8DSI(3),P5DSI(3),P3DSI(3)
       REAL P2NSI(3),P1NSI(3),P8NSI(3),P5NSI(3),P3NSI(3) 
C      Additional local and temporary variables
       REAL XN2DEI,XN1DEI,XN8DEI,XN5DEI,XN3DEI
       REAL XN2NEI,XN1NEI,XN8NEI,XN5NEI,XN3NEI
       REAL DN2DEI,DN1DEI,DN8DEI,DN5DEI,DN3DEI
       REAL DN2NEI,DN1NEI,DN8NEI,DN5NEI,DN3NEI
       REAL XN2DSI,XN1DSI,XN8DSI,XN5DSI,XN3DSI
       REAL XN2NSI,XN1NSI,XN8NSI,XN5NSI,XN3NSI
       REAL DN2DSI,DN1DSI,DN8DSI,DN5DSI,DN3DSI
       REAL DN2NSI,DN1NSI,DN8NSI,DN5NSI,DN3NSI
       REAL MLTTMP
       INTEGER I      
C
       DATA (INVDPQ(I),I=1,13) /-90.0,-75.0,-60.0,-45.0,-30.0,-15.0,
     &                      0.0, 15.0, 30.0, 45.0, 60.0, 75.0,90.0/
C      Equinox
       DATA ((P2DE(I,J),I=1,13),J=1,3) /
     &  125., 120., 115., 113., 118., 119., 118., 119., 118., 113.,
     &  115., 120., 125.,
     &  150., 151., 152., 158., 154., 156., 147., 156., 154., 158.,
     &  152., 151., 150.,
     &  181., 197., 213., 214., 205., 199., 197., 199., 205., 214.,
     &  213., 197., 181./
       DATA (CXN2DE(I),I=1,13) /  587.,  466.,  345.,  264.,  355.,
     &   335.,  229.,  335.,  355.,  264.,  345.,  466.,  587./
       DATA (CDN2DE(I),I=1,13) /  244.,   93.,  -59., -103.,   57.,
     &   170.,   16.,  170.,   57., -103.,  -59.,   93.,  244./
       DATA ((P1DE(I,J),I=1,13),J=1,3) /
     &  111., 110., 109., 109., 109., 110., 109., 110., 109., 109.,
     &  109., 110., 111.,
     &  135., 135., 134., 128., 131., 145., 148., 145., 131., 128.,
     &  134., 135., 135.,
     &  206., 201., 196., 200., 198., 197., 211., 197., 198., 200.,
     &  196., 201., 206./
       DATA (CXN1DE(I),I=1,13) /  929.,  590.,  250.,  375.,  126.,
     &   471.,  427.,  471.,  126.,  375.,  250.,  590.,  929./
       DATA (CDN1DE(I),I=1,13) /  -36.,   19.,   75.,   77.,   51.,
     &   100.,  105.,  100.,   51.,   77.,   75.,   19.,  -36./
       DATA ((P8DE(I,J),I=1,13),J=1,3) /
     &  125., 124., 124., 119., 102.,  89.,  98.,  89., 102., 119.,
     &  124., 124., 125.,
     &  147., 149., 151., 158., 164., 168., 166., 168., 164., 158.,
     &  151., 149., 147.,
     &  195., 194., 193., 195., 196., 191., 190., 191., 196., 195.,
     &  193., 194., 195./
       DATA (CXN8DE(I),I=1,13) /  159.,   75.,   -9., -151.,  511.,
     &   694.,  721.,  694.,  511., -151.,   -9.,   75.,  159./
       DATA (CDN8DE(I),I=1,13) /   53.,   47.,   42.,  -45.,  594.,
     &  1002.,  733., 1002.,  594.,  -45.,   42.,   47.,   53./
       DATA ((P5DE(I,J),I=1,13),J=1,3) /
     &  109., 102.,  95.,  93.,  95.,  92.,  86.,  92.,  95.,  93.,
     &   95., 102., 109.,
     &  161., 165., 169., 167., 160., 162., 164., 162., 160., 167.,
     &  169., 165., 161.,
     &  197., 200., 204., 203., 209., 214., 218., 214., 209., 203.,
     &  204., 200., 197./
       DATA (CXN5DE(I),I=1,13) /  703.,  472.,  242., -524., -241.,
     &   364.,  532.,  364., -241., -524.,  242.,  472.,  703./
       DATA (CDN5DE(I),I=1,13) /  533.,  416.,  300., -591., -398.,
     &   115.,  201.,  115., -398., -591.,  300.,  416.,  533./
       DATA ((P3DE(I,J),I=1,13),J=1,3) /
     &   70.,  78.,  86.,  89.,  90.,  92.,  89.,  92.,  90.,  89.,
     &   86.,  78.,  70.,
     &  159., 155., 152., 153., 152., 147., 143., 147., 152., 153.,
     &  152., 155., 159.,
     &  212., 212., 212., 208., 208., 207., 205., 207., 208., 208.,
     &  212., 212., 212./
       DATA (CXN3DE(I),I=1,13) /  277.,   77., -123., -364., -136.,
     &   317.,  411.,  317., -136., -364., -123.,   77.,  277./
       DATA (CDN3DE(I),I=1,13) /  -24.,  -15.,   -6.,  -74., -217.,
     &   188.,  269.,  188., -217.,  -74.,   -6.,  -15.,  -24./
       DATA ((P2NE(I,J),I=1,13),J=1,3) /
     &  113., 111., 109., 107., 103., 106., 102., 106., 103., 107.,
     &  109., 111., 113.,
     &  155., 157., 160., 158., 157., 146., 137., 146., 157., 158.,
     &  160., 157., 155.,
     &  188., 195., 202., 208., 209., 207., 201., 207., 209., 208.,
     &  202., 195., 188./
       DATA (CXN2NE(I),I=1,13) /   76.,  134.,  192.,  821.,  801.,
     &   583.,  551.,  583.,  801.,  821.,  192.,  134.,   76./
C       DATA (CDN2NE(I),I=1,13) /  -19.,  -83., -148.,  399.,  289.,
C     &   340.,  542.,  340.,  289.,  399., -148.,  -83.,  -19./  
C        equator corrected  
        DATA (CDN2NE(I),I=1,13) /  -19.,  -83., -148.,  399.,  289.,
     &   340.,  340.,  340.,  289.,  399., -148.,  -83.,  -19./
       DATA ((P1NE(I,J),I=1,13),J=1,3) /
     &  112., 111., 109., 108., 109., 110., 109., 110., 109., 108.,
     &  109., 111., 112.,
     &  132., 132., 133., 131., 134., 143., 143., 143., 134., 131.,
     &  133., 132., 132.,
     &  220., 211., 201., 195., 196., 204., 213., 204., 196., 195.,
     &  201., 211., 220./
       DATA (CXN1NE(I),I=1,13) /  806.,  689.,  572.,  607.,  540.,
     &   535.,  443.,  535.,  540.,  607.,  572.,  689.,  806./
       DATA (CDN1NE(I),I=1,13) /  124.,   23.,  -77.,   50.,  128.,
     &   120.,   79.,  120.,  128.,   50.,  -77.,   23.,  124./
       DATA ((P8NE(I,J),I=1,13),J=1,3) /
     &  124., 124., 124., 123., 119., 108., 110., 108., 119., 123.,
     &  124., 124., 124.,
     &  149., 149., 149., 149., 155., 164., 170., 164., 155., 149.,
     &  149., 149., 149.,
     &  195., 195., 194., 193., 194., 195., 194., 195., 194., 193.,
     &  194., 195., 195./
       DATA (CXN8NE(I),I=1,13) /   57.,  -17.,  -90.,  -19.,  260.,
     &   431.,  417.,  431.,  260.,  -19.,  -90.,  -17.,   57./
       DATA (CDN8NE(I),I=1,13) /   18.,   -7.,  -32.,   31.,  139.,
     &   320.,  351.,  320.,  139.,   31.,  -32.,   -7.,   18./
       DATA ((P5NE(I,J),I=1,13),J=1,3) /
     &  112., 105.,  98., 100.,  98.,  91.,  90.,  91.,  98., 100.,
     &   98., 105., 112.,
     &  162., 161., 160., 163., 166., 165., 165., 165., 166., 163.,
     &  160., 161., 162.,
     &  208., 205., 203., 201., 202., 207., 208., 207., 202., 201.,
     &  203., 205., 208./
       DATA (CXN5NE(I),I=1,13) /  575.,  437.,  299.,  198.,  293.,
     &   384.,  403.,  384.,  293.,  198.,  299.,  437.,  575./
       DATA (CDN5NE(I),I=1,13) /  353.,  256.,  159.,   58.,  203.,
     &   253.,  230.,  253.,  203.,   58.,  159.,  256.,  353./
       DATA ((P3NE(I,J),I=1,13),J=1,3) /
     &   72.,  78.,  85.,  90.,  94.,  89.,  88.,  89.,  94.,  90.,
     &   85.,  78.,  72.,
     &  163., 159., 154., 160., 164., 161., 157., 161., 164., 160.,
     &  154., 159., 163.,
     &  212., 211., 210., 205., 208., 224., 231., 224., 208., 205.,
     &  210., 211., 212./
       DATA (CXN3NE(I),I=1,13) / 1457.,  763.,   68.,  153.,  187.,
     &   390.,  364.,  390.,  187.,  153.,   68.,  763., 1457./
       DATA (CDN3NE(I),I=1,13) /  722.,  329.,  -63.,   40.,   31.,
     &   102.,  111.,  102.,   31.,   40.,  -63.,  329.,  722./
C      Solstice
       DATA ((P2DS(I,J),I=1,13),J=1,3) /
     &   90.,  90.,  91.,  91.,  98., 105., 112., 119., 125., 124.,
     &  120., 126., 131.,
     &  155., 156., 156., 161., 163., 158., 152., 155., 154., 147.,
     &  152., 148., 145.,
     &  205., 202., 199., 191., 195., 206., 212., 210., 206., 205.,
     &  203., 201., 199./
       DATA (CXN2DS(I),I=1,13) / -714., -294.,  126.,  546.,  516.,
     &   486.,  456.,  426.,  396.,  225.,  366.,  710., 1055./
       DATA (CDN2DS(I),I=1,13) / -732., -357.,   17.,  392.,  327.,
     &   262.,  197.,  132.,   67.,  -80.,   62.,  330.,  598./
       DATA ((P1DS(I,J),I=1,13),J=1,3) /
     &  105., 107., 108., 112., 111., 111., 112., 113., 113., 113.,
     &  114., 116., 118.,
     &  125., 127., 130., 132., 135., 134., 135., 139., 134., 133.,
     &  135., 136., 137.,
     &  189., 193., 198., 211., 218., 202., 199., 200., 206., 213.,
     &  217., 224., 231./
       DATA (CXN1DS(I),I=1,13) /  706.,  480.,  255.,   56.,  310.,
     &   111.,  164.,  249.,  324.,  629.,  837.,  938., 1038./
       DATA (CDN1DS(I),I=1,13) /   25.,   51.,   77.,   26.,  107.,
     &   131.,  118.,  141.,  130.,   68.,   45.,  123.,  202./
       DATA ((P8DS(I,J),I=1,13),J=1,3) /
     &  125., 122., 120., 121., 119., 116., 113., 110., 107., 114.,
     &  125., 127., 129.,
     &  148., 147., 146., 149., 159., 163., 162., 160., 171., 160.,
     &  154., 152., 150.,
     &  199., 199., 198., 200., 198., 200., 214., 221., 215., 192.,
     &  193., 196., 200./
       DATA (CXN8DS(I),I=1,13) /  201.,   47., -106., -130., -106.,
     &    26.,  158.,  290.,  422.,  214.,  185.,  224.,  263./
       DATA (CDN8DS(I),I=1,13) /  104.,   63.,   22.,   -3.,   -1.,
     &    60.,  121.,  182.,  242.,  170.,   51.,   67.,   84./
       DATA ((P5DS(I,J),I=1,13),J=1,3) /
     &   91.,  88.,  86.,  95.,  94.,  88.,  85.,  90.,  95.,  96.,
     &   96.,  97.,  98.,
     &  165., 167., 168., 150., 159., 161., 161., 159., 158., 158.,
     &  145., 149., 154.,
     &  189., 191., 194., 201., 204., 200., 196., 193., 191., 196.,
     &  204., 201., 199./
       DATA (CXN5DS(I),I=1,13) /-1839.,-1044., -248., -253., -416.,
     &    17.,  156.,  118., -110.,  372.,  934.,  895.,  856./
       DATA (CDN5DS(I),I=1,13) /-1603.,-1092., -581., -656., -433.,
     &  -166.,   51.,  -29., -325.,  117.,  -36.,  321.,  678./
       DATA ((P3DS(I,J),I=1,13),J=1,3) /
     &   97.,  94.,  92.,  94.,  90.,  89.,  90.,  92.,  93.,  91.,
     &   95.,  85.,  75.,
     &  155., 148., 141., 142., 142., 140., 139., 142., 145., 141.,
     &  144., 155., 167.,
     &  197., 200., 204., 207., 200., 203., 206., 209., 212., 219.,
     &  219., 204., 190./
       DATA (CXN3DS(I),I=1,13) / -894., -797., -700., -604.,  139.,
     &   246.,  354.,  462.,  569.,  142.,   81.,  293.,  505./
       DATA (CDN3DS(I),I=1,13) / -740., -577., -414., -140.,   55.,
     &   -27.,  110.,   74.,  -10., -122.,   52.,  209.,  366./
       DATA ((P2NS(I,J),I=1,13),J=1,3) /
     &  105., 107., 110., 112., 115., 110., 104.,  99.,  95., 103.,
     &  117., 127., 136.,
     &  149., 146., 144., 147., 143., 139., 138., 143., 152., 154.,
     &  154., 148., 142.,
     &  198., 200., 201., 206., 211., 210., 209., 200., 196., 197.,
     &  205., 205., 206./
       DATA (CXN2NS(I),I=1,13) / -817., -511., -205.,  100.,  406.,
     &   312.,  217.,  123.,  640., 1037.,  580.,  677.,  773./
       DATA (CDN2NS(I),I=1,13) /  755.,  684.,  612.,  540.,  469.,
     &   191.,  -87., -365., -171., -224., -112.,  146.,  403./
       DATA ((P1NS(I,J),I=1,13),J=1,3) /
     &  104., 108., 112., 112., 114., 113., 112., 112., 112., 114.,
     &  114., 116., 119.,
     &  137., 135., 133., 131., 136., 137., 133., 134., 131., 133.,
     &  135., 135., 134.,
     &  240., 224., 208., 207., 204., 201., 199., 208., 208., 211.,
     &  196., 198., 200./
       DATA (CXN1NS(I),I=1,13) / 1440.,  430., -580.,  201.,  354.,
     &   470.,  281.,  329.,  511.,  546.,  741.,  911., 1082./
       DATA (CDN1NS(I),I=1,13) / -236., -256., -276.,  182.,  155.,
     &   100.,  128.,  148.,  100.,  -61., -102.,   33.,  169./
       DATA ((P8NS(I,J),I=1,13),J=1,3) /
     &  128., 127., 127., 127., 126., 122., 102., 115., 116., 118.,
     &  121., 121., 121.,
     &  153., 153., 153., 153., 154., 158., 163., 156., 150., 146.,
     &  147., 147., 147.,
     &  198., 197., 197., 195., 193., 194., 197., 198., 198., 198.,
     &  198., 198., 199./
       DATA (CXN8NS(I),I=1,13) /  199.,   -8., -215.,   92.,  275.,
     &   284.,  304.,  322.,  284.,  161.,  121.,  200.,  280./
       DATA (CDN8NS(I),I=1,13) /  123.,    1., -121.,   -6.,  151.,
     &   146.,  -19.,  169.,  149.,   75.,   22.,   78.,  134./
       DATA ((P5NS(I,J),I=1,13),J=1,3) /
     &   85.,  89.,  93., 102.,  95.,  85.,  83.,  86.,  97., 101.,
     &   93.,  92.,  90.,
     &  166., 163., 160., 167., 168., 167., 165., 167., 169., 164.,
     &  157., 162., 166.,
     &  217., 207., 196., 183., 193., 194., 197., 205., 209., 205.,
     &  205., 201., 198./
       DATA (CXN5NS(I),I=1,13) /  274.,  246.,  218.,   90.,  248.,
     &   337.,  370.,  433.,  361.,  461.,  541.,  615.,  689./
       DATA (CDN5NS(I),I=1,13) / -153.,  -61.,   30.,   48.,  169.,
     &   241.,  279.,  260.,  187.,  380.,  316.,  436.,  557./
       DATA ((P3NS(I,J),I=1,13),J=1,3) /
     &   74.,  80.,  87.,  89.,  95.,  94.,  92.,  91.,  90.,  93.,
     &   93.,  87.,  81.,
     &  151., 146., 141., 142., 151., 158., 159., 159., 160., 155.,
     &  149., 153., 157.,
     &  221., 205., 189., 184., 180., 175., 176., 179., 191., 199.,
     &  210., 204., 198./
       DATA (CXN3NS(I),I=1,13) /   68.,   34.,    1.,  154.,  151.,
     &   178.,  224.,  198.,  220.,  380.,  559.,  228., -104./
       DATA (CDN3NS(I),I=1,13) /   97.,    1.,  -95.,   47.,   37.,
     &   112.,   96.,  106.,  129.,  252.,  470.,  220.,  -30./
C
       DO 5 I=1,13
        TXN2DE(I)=CXN2DE(I)
        TDN2DE(I)=CDN2DE(I)
        TXN1DE(I)=CXN1DE(I)
        TDN1DE(I)=CDN1DE(I)
        TXN8DE(I)=CXN8DE(I)
        TDN8DE(I)=CDN8DE(I)
        TXN5DE(I)=CXN5DE(I)
        TDN5DE(I)=CDN5DE(I)
        TXN3DE(I)=CXN3DE(I)
        TDN3DE(I)=CDN3DE(I)
        TXN2NE(I)=CXN2NE(I)
        TDN2NE(I)=CDN2NE(I)
        TXN1NE(I)=CXN1NE(I)
        TDN1NE(I)=CDN1NE(I)
        TXN8NE(I)=CXN8NE(I)
        TDN8NE(I)=CDN8NE(I)
        TXN5NE(I)=CXN5NE(I)
        TDN5NE(I)=CDN5NE(I)
        TXN3NE(I)=CXN3NE(I)
        TDN3NE(I)=CDN3NE(I)       
        TXN2DS(I)=CXN2DS(I)
        TDN2DS(I)=CDN2DS(I)
        TXN1DS(I)=CXN1DS(I)
        TDN1DS(I)=CDN1DS(I)
        TXN8DS(I)=CXN8DS(I)
        TDN8DS(I)=CDN8DS(I)
        TXN5DS(I)=CXN5DS(I)
        TDN5DS(I)=CDN5DS(I)
        TXN3DS(I)=CXN3DS(I)
        TDN3DS(I)=CDN3DS(I)
        TXN2NS(I)=CXN2NS(I)
        TDN2NS(I)=CDN2NS(I)
        TXN1NS(I)=CXN1NS(I)
        TDN1NS(I)=CDN1NS(I)
        TXN8NS(I)=CXN8NS(I)
        TDN8NS(I)=CDN8NS(I)
        TXN5NS(I)=CXN5NS(I)
        TDN5NS(I)=CDN5NS(I)
        TXN3NS(I)=CXN3NS(I)
5       TDN3NS(I)=CDN3NS(I)       
C
       IF (((DDD .GE. 265) .AND. (DDD .LT. 354)) .OR. 
     &    ((DDD .GE. 354) .OR. (DDD .LT. 79))) THEN
         CALL SWAPEL(13,TXN2DS)
         CALL SWAPEL(13,TDN2DS)
         CALL SWAPEL(13,TXN1DS)
         CALL SWAPEL(13,TDN1DS)
         CALL SWAPEL(13,TXN8DS)
         CALL SWAPEL(13,TDN8DS)
         CALL SWAPEL(13,TXN5DS)
         CALL SWAPEL(13,TDN5DS)
         CALL SWAPEL(13,TXN3DS)
         CALL SWAPEL(13,TDN3DS)
         CALL SWAPEL(13,TXN2NS)
         CALL SWAPEL(13,TDN2NS)
         CALL SWAPEL(13,TXN1NS)
         CALL SWAPEL(13,TDN1NS)
         CALL SWAPEL(13,TXN8NS)
         CALL SWAPEL(13,TDN8NS)
         CALL SWAPEL(13,TXN5NS)
         CALL SWAPEL(13,TDN5NS)
         CALL SWAPEL(13,TXN3NS)
         CALL SWAPEL(13,TDN3NS)
       END IF
       
C      interpolated Te values for invdip
C      Te max-min day equinox
       XN2DEI=INTERP(13,0,TXN2DE,INVDPQ,INVDIP)
       XN1DEI=INTERP(13,0,TXN1DE,INVDPQ,INVDIP)
       XN8DEI=INTERP(13,0,TXN8DE,INVDPQ,INVDIP)
       XN5DEI=INTERP(13,0,TXN5DE,INVDPQ,INVDIP)
       XN3DEI=INTERP(13,0,TXN3DE,INVDPQ,INVDIP)
C      Te max-min night equinox       
       XN2NEI=INTERP(13,0,TXN2NE,INVDPQ,INVDIP)
       XN1NEI=INTERP(13,0,TXN1NE,INVDPQ,INVDIP)
       XN8NEI=INTERP(13,0,TXN8NE,INVDPQ,INVDIP)
       XN5NEI=INTERP(13,0,TXN5NE,INVDPQ,INVDIP)
       XN3NEI=INTERP(13,0,TXN3NE,INVDPQ,INVDIP)
C      Te med-min day equinox       
       DN2DEI=INTERP(13,0,TDN2DE,INVDPQ,INVDIP)
       DN1DEI=INTERP(13,0,TDN1DE,INVDPQ,INVDIP)
       DN8DEI=INTERP(13,0,TDN8DE,INVDPQ,INVDIP)
       DN5DEI=INTERP(13,0,TDN5DE,INVDPQ,INVDIP)
       DN3DEI=INTERP(13,0,TDN3DE,INVDPQ,INVDIP)
C      Te med-min night equinox       
       DN2NEI=INTERP(13,0,TDN2NE,INVDPQ,INVDIP)
       DN1NEI=INTERP(13,0,TDN1NE,INVDPQ,INVDIP)
       DN8NEI=INTERP(13,0,TDN8NE,INVDPQ,INVDIP)
       DN5NEI=INTERP(13,0,TDN5NE,INVDPQ,INVDIP)
       DN3NEI=INTERP(13,0,TDN3NE,INVDPQ,INVDIP)
C       
C      Te max-min day solstice       
       XN2DSI=INTERP(13,0,TXN2DS,INVDPQ,INVDIP)
       XN1DSI=INTERP(13,0,TXN1DS,INVDPQ,INVDIP)
       XN8DSI=INTERP(13,0,TXN8DS,INVDPQ,INVDIP)
       XN5DSI=INTERP(13,0,TXN5DS,INVDPQ,INVDIP)
       XN3DSI=INTERP(13,0,TXN3DS,INVDPQ,INVDIP)
C      Te max-min night solstice            
       XN2NSI=INTERP(13,0,TXN2NS,INVDPQ,INVDIP)
       XN1NSI=INTERP(13,0,TXN1NS,INVDPQ,INVDIP)
       XN8NSI=INTERP(13,0,TXN8NS,INVDPQ,INVDIP)
       XN5NSI=INTERP(13,0,TXN5NS,INVDPQ,INVDIP)
       XN3NSI=INTERP(13,0,TXN3NS,INVDPQ,INVDIP)
C      Te med-min day solstice      
       DN2DSI=INTERP(13,0,TDN2DS,INVDPQ,INVDIP)
       DN1DSI=INTERP(13,0,TDN1DS,INVDPQ,INVDIP)
       DN8DSI=INTERP(13,0,TDN8DS,INVDPQ,INVDIP)
       DN5DSI=INTERP(13,0,TDN5DS,INVDPQ,INVDIP)
       DN3DSI=INTERP(13,0,TDN3DS,INVDPQ,INVDIP)
C      Te med-min night solstice           
       DN2NSI=INTERP(13,0,TDN2NS,INVDPQ,INVDIP)
       DN1NSI=INTERP(13,0,TDN1NS,INVDPQ,INVDIP)
       DN8NSI=INTERP(13,0,TDN8NS,INVDPQ,INVDIP)
       DN5NSI=INTERP(13,0,TDN5NS,INVDPQ,INVDIP)
       DN3NSI=INTERP(13,0,TDN3NS,INVDPQ,INVDIP)
       DO 10 I=1,3 
        P2DEI(I)=INTERP(13,1,P2DE(1,I),INVDPQ,INVDIP)
        P2NEI(I)=INTERP(13,1,P2NE(1,I),INVDPQ,INVDIP)
        P1DEI(I)=INTERP(13,1,P1DE(1,I),INVDPQ,INVDIP)
        P1NEI(I)=INTERP(13,1,P1NE(1,I),INVDPQ,INVDIP)
        P8DEI(I)=INTERP(13,1,P8DE(1,I),INVDPQ,INVDIP)
        P8NEI(I)=INTERP(13,1,P8NE(1,I),INVDPQ,INVDIP)
        P5DEI(I)=INTERP(13,1,P5DE(1,I),INVDPQ,INVDIP)
        P5NEI(I)=INTERP(13,1,P5NE(1,I),INVDPQ,INVDIP)
        P3DEI(I)=INTERP(13,1,P3DE(1,I),INVDPQ,INVDIP)
        P3NEI(I)=INTERP(13,1,P3NE(1,I),INVDPQ,INVDIP)
                                            
        P2DSI(I)=INTERP(13,1,P2DS(1,I),INVDPQ,INVDIP)
        P2NSI(I)=INTERP(13,1,P2NS(1,I),INVDPQ,INVDIP)
        P1DSI(I)=INTERP(13,1,P1DS(1,I),INVDPQ,INVDIP)
        P1NSI(I)=INTERP(13,1,P1NS(1,I),INVDPQ,INVDIP)
        P8DSI(I)=INTERP(13,1,P8DS(1,I),INVDPQ,INVDIP)
        P8NSI(I)=INTERP(13,1,P8NS(1,I),INVDPQ,INVDIP)
        P5DSI(I)=INTERP(13,1,P5DS(1,I),INVDPQ,INVDIP)
        P5NSI(I)=INTERP(13,1,P5NS(1,I),INVDPQ,INVDIP)
        P3DSI(I)=INTERP(13,1,P3DS(1,I),INVDPQ,INVDIP)
10      P3NSI(I)=INTERP(13,1,P3NS(1,I),INVDPQ,INVDIP)
       MLTTMP=MLT-1
       IF (MLTTMP .LT. 0) MLTTMP=MLTTMP+24.0
       MLTRAD=MLTTMP/24.0*2*3.1415927
      IF (((DDD .GE. 79) .AND. (DDD .LT. 171)) .OR. 
     &    ((DDD .GE. 265) .AND. (DDD .LT. 354))) THEN
C      Equinox     
       CALL TPCAS(MLTRAD,PF107,P2000A,
     &             XN2DEI,DN2DEI,P2DEI,XN2NEI,DN2NEI,P2NEI,TP200A)
       CALL TPCAS(MLTRAD,PF107,P1400A,
     &             XN1DEI,DN1DEI,P1DEI,XN1NEI,DN1NEI,P1NEI,TP140A)
       CALL TPCAS(MLTRAD,PF107,P850A,
     &             XN8DEI,DN8DEI,P8DEI,XN8NEI,DN8NEI,P8NEI,TP850A)
       CALL TPCAS(MLTRAD,PF107,P550A,
     &             XN5DEI,DN5DEI,P5DEI,XN5NEI,DN5NEI,P5NEI,TP550A)
       CALL TPCAS(MLTRAD,PF107,P350A,
     &             XN3DEI,DN3DEI,P3DEI,XN3NEI,DN3NEI,P3NEI,TP350A)
C       Solstice     
       CALL TPCAS(MLTRAD,PF107,P2000B,
     &             XN2DSI,DN2DSI,P2DSI,XN2NSI,DN2NSI,P2NSI,TP200B)
       CALL TPCAS(MLTRAD,PF107,P1400B,
     &             XN1DSI,DN1DSI,P1DSI,XN1NSI,DN1NSI,P1NSI,TP140B)
       CALL TPCAS(MLTRAD,PF107,P850B,
     &             XN8DSI,DN8DSI,P8DSI,XN8NSI,DN8NSI,P8NSI,TP850B)
       CALL TPCAS(MLTRAD,PF107,P550B,
     &             XN5DSI,DN5DSI,P5DSI,XN5NSI,DN5NSI,P5NSI,TP550B)
       CALL TPCAS(MLTRAD,PF107,P350B,
     &             XN3DSI,DN3DSI,P3DSI,XN3NSI,DN3NSI,P3NSI,TP350B)      
      END IF
      IF (((DDD .GE. 171) .AND. (DDD .LT. 265)) .OR. 
     &    ((DDD .GE. 354) .OR. (DDD .LT. 79)))  THEN
C       Solstice     
       CALL TPCAS(MLTRAD,PF107,P2000A,
     &             XN2DSI,DN2DSI,P2DSI,XN2NSI,DN2NSI,P2NSI,TP200A)
       CALL TPCAS(MLTRAD,PF107,P1400A,
     &             XN1DSI,DN1DSI,P1DSI,XN1NSI,DN1NSI,P1NSI,TP140A)
       CALL TPCAS(MLTRAD,PF107,P850A,
     &             XN8DSI,DN8DSI,P8DSI,XN8NSI,DN8NSI,P8NSI,TP850A)
       CALL TPCAS(MLTRAD,PF107,P550A,
     &             XN5DSI,DN5DSI,P5DSI,XN5NSI,DN5NSI,P5NSI,TP550A)
       CALL TPCAS(MLTRAD,PF107,P350A,
     &             XN3DSI,DN3DSI,P3DSI,XN3NSI,DN3NSI,P3NSI,TP350A)  
C      Equinox     
       CALL TPCAS(MLTRAD,PF107,P2000B,
     &             XN2DEI,DN2DEI,P2DEI,XN2NEI,DN2NEI,P2NEI,TP200B)
       CALL TPCAS(MLTRAD,PF107,P1400B,
     &             XN1DEI,DN1DEI,P1DEI,XN1NEI,DN1NEI,P1NEI,TP140B)
       CALL TPCAS(MLTRAD,PF107,P850B,
     &             XN8DEI,DN8DEI,P8DEI,XN8NEI,DN8NEI,P8NEI,TP850B)
       CALL TPCAS(MLTRAD,PF107,P550B,
     &             XN5DEI,DN5DEI,P5DEI,XN5NEI,DN5NEI,P5NEI,TP550B)
       CALL TPCAS(MLTRAD,PF107,P350B,
     &             XN3DEI,DN3DEI,P3DEI,XN3NEI,DN3NEI,P3NEI,TP350B)     
      END IF 
      RETURN
      END
c
c
      SUBROUTINE TEBA(DIPL,SLT,NS,TE) 
C CALCULATES ELECTRON TEMPERATURES TE(1) TO TE(4) AT ALTITUDES
C 300, 400, 1400 AND 3000 KM FOR DIP-LATITUDE DIPL/DEG AND 
C LOCAL SOLAR TIME SLT/H USING THE BRACE-THEIS-MODELS (J. ATMOS.
C TERR. PHYS. 43, 1317, 1981); NS IS SEASON IN NORTHERN
C HEMISOHERE: IS=1 SPRING, IS=2 SUMMER ....
C ALSO CALCULATED ARE THE TEMPERATURES AT 400 KM ALTITUDE FOR
C MIDNIGHT (TE(5)) AND NOON (TE(6)).   
      DIMENSION C(4,2,81),A(82),TE(6)
      COMMON    /CONST/UMR      /const1/humr,dumr
      DATA (C(1,1,J),J=1,81)/                      
     &.3100E1,-.3215E-2,.2440E+0,-.4613E-3,-.1711E-1,.2605E-1,                  
     &-.9546E-1,.1794E-1,.1270E-1,.2791E-1,.1536E-1,-.6629E-2,                  
     &-.3616E-2,.1229E-1,.4147E-3,.1447E-2,-.4453E-3,-.1853,                    
     &-.1245E-1,-.3675E-1,.4965E-2,.5460E-2,.8117E-2,-.1002E-1,                 
     &.5466E-3,-.3087E-1,-.3435E-2,-.1107E-3,.2199E-2,.4115E-3,                 
     &.6061E-3,.2916E-3,-.6584E-1,.4729E-2,-.1523E-2,.6689E-3,                  
     &.1031E-2,.5398E-3,-.1924E-2,-.4565E-1,.7244E-2,-.8543E-4,                 
     &.1052E-2,-.6696E-3,-.7492E-3,.4405E-1,.3047E-2,.2858E-2,                  
     &-.1465E-3,.1195E-2,-.1024E-3,.4582E-1,.8749E-3,.3011E-3,                  
     &.4473E-3,-.2782E-3,.4911E-1,-.1016E-1,.27E-2,-.9304E-3,                   
     &-.1202E-2,.2210E-1,.2566E-2,-.122E-3,.3987E-3,-.5744E-1,                  
     &.4408E-2,-.3497E-2,.83E-3,-.3536E-1,-.8813E-2,.2423E-2,                   
     &-.2994E-1,-.1929E-2,-.5268E-3,-.2228E-1,.3385E-2,                         
     &.413E-1,.4876E-2,.2692E-1,.1684E-2/          
      DATA (C(1,2,J),J=1,81)/.313654E1,.6796E-2,.181413,.8564E-1,               
     &-.32856E-1,-.3508E-2,-.1438E-1,-.2454E-1,.2745E-2,.5284E-1,               
     &.1136E-1,-.1956E-1,-.5805E-2,.2801E-2,-.1211E-2,.4127E-2,                 
     &.2909E-2,-.25751,-.37915E-2,-.136E-1,-.13225E-1,.1202E-1,                 
     &.1256E-1,-.12165E-1,.1326E-1,-.7123E-1,.5793E-3,.1537E-2,                 
     &.6914E-2,-.4173E-2,.1052E-3,-.5765E-3,-.4041E-1,-.1752E-2,                
     &-.542E-2,-.684E-2,.8921E-3,-.2228E-2,.1428E-2,.6635E-2,-.48045E-2,        
     &-.1659E-2,-.9341E-3,.223E-3,-.9995E-3,.4285E-1,-.5211E-3,                 
     &-.3293E-2,.179E-2,.6435E-3,-.1891E-3,.3844E-1,.359E-2,-.8139E-3,          
     &-.1996E-2,.2398E-3,.2938E-1,.761E-2,.347655E-2,.1707E-2,.2769E-3,         
     &-.157E-1,.983E-3,-.6532E-3,.929E-4,-.2506E-1,.4681E-2,.1461E-2,           
     &-.3757E-5,-.9728E-2,.2315E-2,.6377E-3,-.1705E-1,.2767E-2,                 
     &-.6992E-3,-.115E-1,-.1644E-2,.3355E-2,-.4326E-2,.2035E-1,.2985E-1/        
      DATA (C(2,1,J),J=1,81)/.3136E1,.6498E-2,.2289,.1859E-1,-.3328E-1,         
     &-.4889E-2,-.3054E-1,-.1773E-1,-.1728E-1,.6555E-1,.1775E-1,                
     &-.2488E-1,-.9498E-2,.1493E-1,.281E-2,.2406E-2,.5436E-2,-.2115,            
     &.7007E-2,-.5129E-1,-.7327E-2,.2402E-1,.4772E-2,-.7374E-2,                 
     &-.3835E-3,-.5013E-1,.2866E-2,.2216E-2,.2412E-3,.2094E-2,.122E-2           
     &,-.1703E-3,-.1082,-.4992E-2,-.4065E-2,.3615E-2,-.2738E-2,                 
     &-.7177E-3,.2173E-3,-.4373E-1,-.375E-2,.5507E-2,-.1567E-2,                 
     &-.1458E-2,-.7397E-3,.7903E-1,.4131E-2,.3714E-2,.1073E-2,                  
     &-.8991E-3,.2976E-3,.2623E-1,.2344E-2,.5608E-3,.4124E-3,.1509E-3,          
     &.5103E-1,.345E-2,.1283E-2,.7238E-3,-.3464E-4,.1663E-1,-.1644E-2,          
     &-.71E-3,.5281E-3,-.2729E-1,.3556E-2,-.3391E-2,-.1787E-3,.2154E-2,         
     &.6476E-2,-.8282E-3,-.2361E-1,.9557E-3,.3205E-3,-.2301E-1,                 
     &-.854E-3,-.1126E-1,-.2323E-2,-.8582E-2,.2683E-1/                          
      DATA (C(2,2,J),J=1,81)/.3144E1,.8571E-2,.2539,.6937E-1,-.1667E-1,         
     &.2249E-1,-.4162E-1,.1201E-1,.2435E-1,.5232E-1,.2521E-1,-.199E-1,          
     &-.7671E-2,.1264E-1,-.1551E-2,-.1928E-2,.3652E-2,-.2019,.5697E-2,          
     &-.3159E-1,-.1451E-1,.2868E-1,.1377E-1,-.4383E-2,.1172E-1,                 
     &-.5683E-1,.3593E-2,.3571E-2,.3282E-2,.1732E-2,-.4921E-3,-.1165E-2         
     &,-.1066,-.1892E-1,.357E-2,-.8631E-3,-.1876E-2,-.8414E-4,.2356E-2,         
     &-.4259E-1,-.322E-2,.4641E-2,.6223E-3,-.168E-2,-.1243E-3,.7393E-1,         
     &-.3143E-2,-.2362E-2,.1235E-2,-.1551E-2,.2099E-3,.2299E-1,.5301E-2         
     &,-.4306E-2,-.1303E-2,.7687E-5,.5305E-1,.6642E-2,-.1686E-2,                
     &.1048E-2,.5958E-3,.4341E-1,-.8819E-4,-.333E-3,-.2158E-3,-.4106E-1         
     &,.4191E-2,.2045E-2,-.1437E-3,-.1803E-1,-.8072E-3,-.424E-3,                
     &-.26E-1,-.2329E-2,.5949E-3,-.1371E-1,-.2188E-2,.1788E-1,                  
     &.6405E-3,.5977E-2,.1333E-1/                  
      DATA (C(3,1,J),J=1,81)/.3372E1,.1006E-1,.1436,.2023E-2,-.5166E-1,         
     &.9606E-2,-.5596E-1,.4914E-3,-.3124E-2,-.4713E-1,-.7371E-2,                
     &-.4823E-2,-.2213E-2,.6569E-2,-.1962E-3,.3309E-3,-.3908E-3,                
     &-.2836,.7829E-2,.1175E-1,.9919E-3,.6589E-2,.2045E-2,-.7346E-2             
     &,-.89E-3,-.347E-1,-.4977E-2,.147E-2,-.2823E-5,.6465E-3,                   
     &-.1448E-3,.1401E-2,-.8988E-1,-.3293E-4,-.1848E-2,.4439E-3,                
     &-.1263E-2,.317E-3,-.6227E-3,.1721E-1,-.199E-2,-.4627E-3,                  
     &.2897E-5,-.5454E-3,.3385E-3,.8432E-1,-.1951E-2,.1487E-2,                  
     &.1042E-2,-.4788E-3,-.1276E-3,.2373E-1,.2409E-2,.5263E-3,                  
     &.1301E-2,-.4177E-3,.3974E-1,.1418E-3,-.1048E-2,-.2982E-3,                 
     &-.3396E-4,.131E-1,.1413E-2,-.1373E-3,.2638E-3,-.4171E-1,                  
     &-.5932E-3,-.7523E-3,-.6883E-3,-.2355E-1,.5695E-3,-.2219E-4,               
     &-.2301E-1,-.9962E-4,-.6761E-3,.204E-2,-.5479E-3,.2591E-1,                 
     &-.2425E-2,.1583E-1,.9577E-2/                 
      DATA (C(3,2,J),J=1,81)/.3367E1,.1038E-1,.1407,.3622E-1,-.3144E-1,         
     &.112E-1,-.5674E-1,.3219E-1,.1288E-2,-.5799E-1,-.4609E-2,                  
     &.3252E-2,-.2859E-3,.1226E-1,-.4539E-2,.1310E-2,-.5603E-3,                 
     &-.311,-.1268E-2,.1539E-1,.3146E-2,.7787E-2,-.143E-2,-.482E-2              
     &,.2924E-2,-.9981E-1,-.7838E-2,-.1663E-3,.4769E-3,.4148E-2,                
     &-.1008E-2,-.979E-3,-.9049E-1,-.2994E-2,-.6748E-2,-.9889E-3,               
     &.1488E-2,-.1154E-2,-.8412E-4,-.1302E-1,-.4859E-2,-.7172E-3,               
     &-.9401E-3,.9101E-3,-.1735E-3,.7055E-1,.6398E-2,-.3103E-2,                 
     &-.938E-3,-.4E-3,-.1165E-2,.2713E-1,-.1654E-2,.2781E-2,                    
     &-.5215E-5,.2258E-3,.5022E-1,.95E-2,.4147E-3,.3499E-3,                     
     &-.6097E-3,.4118E-1,.6556E-2,.3793E-2,-.1226E-3,-.2517E-1,                 
     &.1491E-3,.1075E-2,.4531E-3,-.9012E-2,.3343E-2,.3431E-2,                   
     &-.2519E-1,.3793E-4,.5973E-3,-.1423E-1,-.132E-2,-.6048E-2,                 
     &-.5005E-2,-.115E-1,.2574E-1/                 
      DATA (C(4,1,J),J=1,81)/.3574E1,.0,.7537E-1,.0,-.8459E-1,                  
     &0.,-.294E-1,0.,.4547E-1,-.5321E-1,0.,.4328E-2,0.,.6022E-2,                
     &.0,-.9168E-3,.0,-.1768,.0,.294E-1,.0,.5902E-3,.0,-.9047E-2,               
     &.0,-.6555E-1,.0,-.1033E-2,.0,.1674E-2,.0,.2802E-3,-.6786E-1               
     &,.0,.4193E-2,.0,-.6448E-3,.0,.9277E-3,-.1634E-1,.0,-.2531E-2              
     &,.0,.193E-4,.0,.528E-1,.0,.2438E-2,.0,-.5292E-3,.0,.1555E-1               
     &,.0,-.3259E-2,.0,-.5998E-3,.3168E-1,.0,.2382E-2,.0,-.4078E-3              
     &,.2312E-1,.0,.1481E-3,.0,-.1885E-1,.0,.1144E-2,.0,-.9952E-2               
     &,.0,-.551E-3,-.202E-1,.0,-.7283E-4,-.1272E-1,.0,.2224E-2,                 
     &.0,-.251E-2,.2434E-1/                        
      DATA (C(4,2,J),J=1,81)/.3574E1,-.5639E-2,.7094E-1,                        
     &-.3347E-1,-.861E-1,-.2877E-1,-.3154E-1,-.2847E-2,.1235E-1,                
     &-.5966E-1,-.3236E-2,.3795E-3,-.8634E-3,.3377E-2,-.1071E-3,                
     &-.2151E-2,-.4057E-3,-.1783,.126E-1,.2835E-1,-.242E-2,                     
     &.3002E-2,-.4684E-2,-.6756E-2,-.7493E-3,-.6147E-1,-.5636E-2                
     &,-.1234E-2,-.1613E-2,-.6353E-4,-.2503E-3,-.1729E-3,-.7148E-1              
     &,.5326E-2,.4006E-2,.6484E-3,-.1046E-3,-.6034E-3,-.9435E-3,                
     &-.2385E-2,.6853E-2,.151E-2,.1319E-2,.9049E-4,-.1999E-3,                   
     &.3976E-1,.2802E-2,-.103E-2,.5599E-3,-.4791E-3,-.846E-4,                   
     &.2683E-1,.427E-2,.5911E-3,.2987E-3,-.208E-3,.1396E-1,                     
     &-.1922E-2,-.1063E-2,.3803E-3,.1343E-3,.1771E-1,-.1038E-2,                 
     &-.4645E-3,-.2481E-3,-.2251E-1,-.29E-2,-.3977E-3,-.516E-3,                 
     &-.8079E-2,-.1528E-2,.306E-3,-.1582E-1,-.8536E-3,.1565E-3,                 
     &-.1252E-1,.2319E-3,.4311E-2,.1024E-2,.1296E-5,.179E-1/                    
        IF(NS.LT.3) THEN
           IS=NS
        ELSE IF(NS.GT.3) THEN
           IS=2
           DIPL=-DIPL
        ELSE
           IS=1
        ENDIF
      COLAT=UMR*(90.-DIPL)                    
      AZ=humr*SLT    
      CALL SPHARM(A,8,8,COLAT,AZ)
        IF(IS.EQ.2) THEN
           KEND=3
        ELSE
           KEND=4
        ENDIF                  
      DO 2 K=1,KEND      
      STE=0.          
      DO 1 I=1,81     
1       STE=STE+A(I)*C(K,IS,I)                       
2     TE(K)=10.**STE
        IF(IS.EQ.2) THEN
           DIPL=-DIPL
           COLAT=UMR*(90.-DIPL)                    
           CALL SPHARM(A,8,8,COLAT,AZ)
           STE=0.          
           DO 11 I=1,81     
11            STE=STE+A(I)*C(4,2,I)                       
           TE(4)=10.**STE
        ENDIF

C---------- TEMPERATURE AT 400KM AT MIDNIGHT AND NOON
      DO 4 J=1,2      
        STE=0.          
        AZ=humr*(J-1)*12.                           
        CALL SPHARM(A,8,8,COLAT,AZ)                  
        DO 3 I=1,81     
3         STE=STE+A(I)*C(2,IS,I)                       
4       TE(J+4)=10.**STE                             
      RETURN          
      END             
C
      SUBROUTINE SPHARM(C,L,M,COLAT,AZ)            
C CALCULATES THE COEFFICIENTS OF THE SPHERICAL HARMONIC                         
C EXPANSION THAT WAS USED FOR THE BRACE-THEIS-MODELS.                           
      DIMENSION C(82)                              
      C(1)=1.         
      K=2             
      X=COS(COLAT)    
      C(K)=X          
      K=K+1           
      DO 10 I=2,L     
      C(K)=((2*I-1)*X*C(K-1)-(I-1)*C(K-2))/I       
10    K=K+1           
      Y=SIN(COLAT)    
      DO 20 MT=1,M    
      CAZ=COS(MT*AZ)  
      SAZ=SIN(MT*AZ)  
      C(K)=Y**MT      
      K=K+1           
      IF(MT.EQ.L) GOTO 16                          
      C(K)=C(K-1)*X*(2*MT+1)                       
      K=K+1           
      IF((MT+1).EQ.L) GOTO 16                      
      DO 15 I=2+MT,L  
      C(K)=((2*I-1)*X*C(K-1)-(I+MT-1)*C(K-2))/(I-MT)                            
15    K=K+1           
16    N=L-MT+1        
      DO 18 I=1,N     
      C(K)=C(K-N)*CAZ                              
      C(K-N)=C(K-N)*SAZ                            
18    K=K+1           
20    CONTINUE        
      RETURN          
      END             
C
C
      REAL FUNCTION ELTE(H)
c----------------------------------------------------------------
C ELECTRON TEMPERATURE PROFILE BASED ON THE TEMPERATURES AT 7 FIXED
C HEIGHTS (AH(7)) AND THE TEMPERATURE GRADIENTS BETWEEN THESE THESE 
C HEIGHTS (ST(6)) GIVEN IN THE COMMON BLOCK. ATE1 IS THE TEMPERATURE
C AT THE STARTING HEIGHT 120 KM. D(5) DEFINE THE TRANSITION SPAN FROM
C ONE CONSTANT GRADIENT REGION TO THE NEXT.
c----------------------------------------------------------------
      COMMON /BLOTE/AH(7),ATE1,ST(6),D(5)
C
      SUM=ATE1+ST(1)*(H-AH(1))                     
      DO 1 I=1,5
        aa = eptr(h    ,d(i),ah(i+1))
        bb = eptr(ah(1),d(i),ah(i+1))
1     SUM=SUM+(ST(I+1)-ST(I))*(AA-BB)*D(I)                
      ELTE=SUM        
      RETURN          
      END             
C
C
      FUNCTION TEDE(H,DEN,COV)                     
C ELECTRON TEMEPERATURE MODEL AFTER BRACE,THEIS .  
C FOR NEG. COV THE MEAN COV-INDEX (3 SOLAR ROT.) IS EXPECTED.                   
C DEN IS THE ELECTRON DENSITY IN M-3.              
      Y=1051.+(17.01*H-2746.)*                     
     &EXP(-5.122E-4*H+(6.094E-12-3.353E-14*H)*DEN) 
      ACOV=ABS(COV)   
      YC=1.+(.117+2.02E-3*ACOV)/(1.+EXP(-(ACOV-102.5)/5.))                      
      IF(COV.LT.0.)   
     &YC=1.+(.123+1.69E-3*ACOV)/(1.+EXP(-(ACOV-115.)/10.))                      
      TEDE=Y*YC       
      RETURN          
      END             
C
C                     
C*************************************************************                  
C**************** ION TEMPERATURE ****************************
C*************************************************************                  
C
C
      REAL FUNCTION TI(H)
c----------------------------------------------------------------
C ION TEMPERATURE FOR HEIGHTS NOT GREATER 1000 KM AND NOT LESS HS               
C EXPLANATION SEE FUNCTION RPID.                   
c----------------------------------------------------------------
      REAL              MM
      COMMON  /BLOCK8/  HS,TNHS,XSM(4),MM(5),G(4),M

      SUM=MM(1)*(H-HS)+TNHS                        
      DO 100 I=1,M-1  
        aa = eptr(h ,g(i),xsm(i))
        bb = eptr(hs,g(i),xsm(i))
100     SUM=SUM+(MM(I+1)-MM(I))*(AA-BB)*G(I)                
      TI=SUM          
      RETURN          
      END             
C
C                     
C*************************************************************                  
C************* ION RELATIVE PRECENTAGE DENSITY *****************                
C*************************************************************                  
C
C
      REAL FUNCTION RPID (H, H0, N0, M, ST, ID, XS)
c------------------------------------------------------------------
C D.BILITZA,1977,THIS ANALYTIC FUNCTION IS USED TO REPRESENT THE                
C RELATIVE PRECENTAGE DENSITY OF ATOMAR AND MOLECULAR OXYGEN IONS.              
C THE M+1 HEIGHT GRADIENTS ST(M+1) ARE CONNECTED WITH EPSTEIN-                  
C STEP-FUNCTIONS AT THE STEP HEIGHTS XS(M) WITH TRANSITION                      
C THICKNESSES ID(M). RPID(H0,H0,N0,....)=N0.       
C ARGMAX is the highest allowed argument for EXP in your system.
c------------------------------------------------------------------
      REAL              N0         
      DIMENSION         ID(4), ST(5), XS(4)                
      COMMON  /ARGEXP/  ARGMAX

      SUM=(H-H0)*ST(1)                             
      DO 100  I=1,M   
              XI=ID(I)
                aa = eptr(h ,xi,xs(i))
                bb = eptr(h0,xi,xs(i))
100           SUM=SUM+(ST(I+1)-ST(I))*(AA-BB)*XI 
      IF(ABS(SUM).LT.ARGMAX) then
        SM=EXP(SUM)
      else IF(SUM.Gt.0.0) then
        SM=EXP(ARGMAX)
      else
        SM=0.0
      endif
      RPID= n0 * SM        
      RETURN          
      END             
C
c
      SUBROUTINE RDHHE (H,HB,RDOH,RDO2H,RNO,PEHE,RDH,RDHE)                      
C BILITZA,FEB.82,H+ AND HE+ RELATIVE PERECENTAGE DENSITY BELOW                  
C 1000 KM. THE O+ AND O2+ REL. PER. DENSITIES SHOULD BE GIVEN                   
C (RDOH,RDO2H). HB IS THE ALTITUDE OF MAXIMAL O+ DENSITY. PEHE                  
C IS THE PRECENTAGE OF HE+ IONS COMPARED TO ALL LIGHT IONS.                     
C RNO IS THE RATIO OF NO+ TO O2+DENSITY AT H=HB.   
      RDHE=0.0        
      RDH=0.0         
      IF(H.LE.HB) GOTO 100                         
      REST=100.0-RDOH-RDO2H-RNO*RDO2H              
      RDH=REST*(1.-PEHE/100.)                      
      RDHE=REST*PEHE/100.                          
100   RETURN          
      END             
C
C
      REAL FUNCTION RDNO(H,HB,RDO2H,RDOH,RNO)      
C D.BILITZA, 1978. NO+ RELATIVE PERCENTAGE DENSITY ABOVE 100KM.                 
C FOR MORE INFORMATION SEE SUBROUTINE RDHHE.       
      IF (H.GT.HB) GOTO 200                        
      RDNO=100.0-RDO2H-RDOH                        
      RETURN          
200   RDNO=RNO*RDO2H  
      RETURN          
      END
C
C
      SUBROUTINE  KOEFP1(PG1O)                     
C THIEMANN,1979,COEFFICIENTS PG1O FOR CALCULATING  O+ PROFILES                  
C BELOW THE F2-MAXIMUM. CHOSEN TO APPROACH DANILOV-                             
C SEMENOV'S COMPILATION.                           
      DIMENSION PG1O(80)                           
      REAL FELD (80)  
      DATA FELD/-11.0,-11.0,4.0,-11.0,0.08018,     
     &0.13027,0.04216,0.25  ,-0.00686,0.00999,     
     &5.113,0.1 ,170.0,180.0,0.1175,0.15,-11.0,    
     &1.0 ,2.0,-11.0,0.069,0.161,0.254,0.18,0.0161,                             
     &0.0216,0.03014,0.1,152.0,167.0,0.04916,      
     &0.17,-11.0,2.0,2.0,-11.0,0.072,0.092,0.014,0.21,                          
     &0.01389,0.03863,0.05762,0.12,165.0,168.0,0.008,                           
     &0.258,-11.0,1.0,3.0,-11.0,0.091,0.088,       
     &0.008,0.34,0.0067,0.0195,0.04,0.1,158.0,172.0,                            
     &0.01,0.24,-11.0,2.0,3.0, -11.0,0.083,0.102,  
     &0.045,0.03,0.00127,0.01,0.05,0.09,167.0,185.0,                            
     &0.015,0.18/     
      K=0             
      DO 10 I=1,80    
      K=K+1           
10    PG1O(K)=FELD(I)                              
      RETURN          
      END             
C
C
      SUBROUTINE KOEFP2(PG2O)                      
C THIEMANN,1979,COEFFICIENTS FOR CALCULATION OF O+ PROFILES                     
C ABOVE THE F2-MAXIMUM (DUMBS,SPENNER:AEROS-COMPILATION)                        
      DIMENSION PG2O(32)                           
      REAL FELD(32)   
      DATA FELD/1.0,-11.0,-11.0,1.0,695.0,-.000781,                             
     &-.00264,2177.0,1.0,-11.0,-11.0,2.0,570.0,    
     &-.002,-.0052,1040.0,2.0,-11.0,-11.0,1.0,695.0,                            
     &-.000786,-.00165,3367.0,2.0,-11.0,-11.0,2.0, 
     &575.0,-.00126,-.00524,1380.0/                
      K=0             
      DO 10 I=1,32    
      K=K+1           
10    PG2O(K)=FELD(I)                              
      RETURN          
      END             
C
C
      SUBROUTINE  KOEFP3(PG3O)                     
C THIEMANN,1979,COEFFICIENTS FOR CALCULATING O2+ PROFILES.                      
C CHOSEN AS TO APPROACH DANILOV-SEMENOV'S COMPILATION.                          
      DIMENSION PG3O(80)                           
      REAL FELD(80)   
      DATA FELD/-11.0,1.0,2.0,-11.0,160.0,31.0,130.0,                           
     &-10.0,198.0,0.0,0.05922,-0.07983,            
     &-0.00397,0.00085,-0.00313,0.0,-11.0,2.0,2.0,-11.0,                        
     &140.0,30.0,130.0,-10.0,                      
     &190.0,0.0,0.05107,-0.07964,0.00097,-0.01118,-0.02614,                     
     &-0.09537,       
     &-11.0,1.0,3.0,-11.0,140.0,37.0,125.0,0.0,182.0,                           
     &0.0,0.0307,-0.04968,-0.00248,                
     &-0.02451,-0.00313,0.0,-11.0,2.0,3.0,-11.0,   
     &140.0,37.0,125.0,0.0,170.0,0.0,              
     &0.02806,-0.04716,0.00066,-0.02763,-0.02247,-0.01919,                      
     &-11.0,-11.0,4.0,-11.0,140.0,45.0,136.0,-9.0, 
     &181.0,-26.0,0.02994,-0.04879,                
     &-0.01396,0.00089,-0.09929,0.05589/           
      K=0             
      DO 10 I=1,80    
      K=K+1           
10    PG3O(K)=FELD(I)                              
      RETURN          
      END             
C
C
      SUBROUTINE SUFE (FIELD,RFE,M,FE)             
C SELECTS THE REQUIRED ION DENSITY PARAMETER SET.
C THE INPUT FIELD INCLUDES DIFFERENT SETS OF DIMENSION M EACH                
C CARACTERISED BY 4 HEADER NUMBERS. RFE(4) SHOULD CONTAIN THE                   
C CHOSEN HEADER NUMBERS.FE(M) IS THE CORRESPONDING SET.                         
      DIMENSION RFE(4),FE(12),FIELD(80),EFE(4)     
      K=0             
100   DO 101 I=1,4    
      K=K+1           
101   EFE(I)=FIELD(K)                              
      DO 111 I=1,M    
      K=K+1           
111   FE(I)=FIELD(K)  
      DO 120 I=1,4    
      IF((EFE(I).GT.-10.0).AND.(RFE(I).NE.EFE(I))) GOTO 100                     
120   CONTINUE        
      RETURN          
      END             
C
C
        subroutine iondani(id,ismo,hx,zd,fd,fs,dion)
c-------------------------------------------------------
c       id      day of month
c       ismo    seasonal month (Northern Hemisphere January 
c                   is ismo=1 and so is Southern H. July)
c       hx      altitude in km
c       zd      solar zenith angle in degrees
c       fd      latitude in degrees
c       fs      10.7cm solar radio flux (12-month running mean)
c       dion(1)   O+  relative density in percent
c       dion(2)   H+  relative density in percent
c       dion(3)   N+  relative density in percent
c       dion(4)   He+ relative density in percent
c       dion(5)   NO+ relative density in percent
c       dion(6)   O2+ relative density in percent
c       dion(7)   Cluster+ relative density in percent
c
c Uses ionco2 (DS-95) for the molecular ions and ionco1 (DY-85)
c for the atomic ions.
c-------------------------------------------------------
        dimension       dion(7)
        common  /const/ umr

        do 1122 i=1,7
1122    dion(i)=0.

        h = hx
        xhi = zd
        xlati = fd
        f107 = fs
        deci_month = ismo + id/29.0
        if (h.gt.300.) then
        	call ionco1(h,xhi,xlati,f107,deci_month,dion)
			dion(5)=0.0
			dion(6)=0.0
			dion(7)=0.0
        else
        	call ionco2(h,xhi,ismo,f107,rno,ro2,rcl,ro)
        	dion(5)=rno
        	dion(6)=ro2
       		dion(7)=rcl
        	dion(1)=ro
        endif

        return
        end
c
c
        subroutine ionco1(h,zd,fd,fs,t,cn)
c---------------------------------------------------------------
c ion composition model
c   A.D. Danilov and A.P. Yaichnikov, A New Model of the Ion
c   Composition at 75 to 1000 km for IRI, Adv. Space Res. 5, #7,
c   75-79, 107-108, 1985
c
c       h       altitude in km
c       zd      solar zenith angle in degrees
c       fd      latitude in degrees (same result for fd and -fd)
c       fs      10.7cm solar radio flux
c       t       seasonal decimal month (Northern Hemisphere January 
c                   15 is t=1.5 and so is Southern Hemisphere July 15)
c       cn(1)   O+  relative density in percent
c       cn(2)   H+  relative density in percent
c       cn(3)   N+  relative density in percent
c       cn(4)   He+ relative density in percent
c Please note: molecular ions are now computed in IONCO2
c       [cn(5)   NO+ relative density in percent
c       [cn(6)   O2+ relative density in percent
c       [cn(7)   cluster ions  relative density in percent
c---------------------------------------------------------------
c
c        dimension       cn(7),cm(7),hm(7),alh(7),all(7),beth(7),
c     &                  betl(7),p(5,6,7),var(6),po(5,6),ph(5,6),
c     &                  pn(5,6),phe(5,6),pno(5,6),po2(5,6),pcl(5,6)
        dimension       cn(4),cm(4),hm(4),alh(4),all(4),beth(4),
     &                  betl(4),p(5,6,4),var(6),po(5,6),ph(5,6),
     &                  pn(5,6),phe(5,6)

        common  /argexp/argmax
        common  /const/ umr
        data po/4*0.,98.5,4*0.,320.,4*0.,-2.59E-4,2.79E-4,-3.33E-3,
     &          -3.52E-3,-5.16E-3,-2.47E-2,4*0.,-2.5E-6,1.04E-3,
     &          -1.79E-4,-4.29E-5,1.01E-5,-1.27E-3/
        data ph/-4.97E-7,-1.21E-1,-1.31E-1,0.,98.1,355.,-191.,
     &          -127.,0.,2040.,4*0.,-4.79E-6,-2.E-4,5.67E-4,
     &          2.6E-4,0.,-5.08E-3,10*0./
        data pn/7.6E-1,-5.62,-4.99,0.,5.79,83.,-369.,-324.,0.,593.,
     &          4*0.,-6.3E-5,-6.74E-3,-7.93E-3,-4.65E-3,0.,-3.26E-3,
     &          4*0.,-1.17E-5,4.88E-3,-1.31E-3,-7.03E-4,0.,-2.38E-3/
        data phe/-8.95E-1,6.1,5.39,0.,8.01,4*0.,1200.,4*0.,-1.04E-5,
     &          1.9E-3,9.53E-4,1.06E-3,0.,-3.44E-3,10*0./ 
c       data pno/-22.4,17.7,-13.4,-4.88,62.3,32.7,0.,19.8,2.07,115.,
c    &          5*0.,3.94E-3,0.,2.48E-3,2.15E-4,6.67E-3,5*0.,
c    &          -8.4E-3,0.,-3.64E-3,2.E-3,-2.59E-2/
c       data po2/8.,-12.2,9.9,5.8,53.4,-25.2,0.,-28.5,-6.72,120.,
c    &          5*0.,-1.4E-2,0.,-9.3E-3,3.3E-3,2.8E-2,5*0.,4.25E-3,
c    &          0.,-6.04E-3,3.85E-3,-3.64E-2/
c       data pcl/4*0.,100.,4*0.,75.,10*0.,4*0.,-9.04E-3,-7.28E-3,
c    &          2*0.,3.46E-3,-2.11E-2/

        z=zd*umr
        f=fd*umr

        DO 8 I=1,5
        DO 8 J=1,6
                p(i,j,1)=po(i,j)
                p(i,j,2)=ph(i,j)
                p(i,j,3)=pn(i,j)
                p(i,j,4)=phe(i,j)
c               p(i,j,5)=pno(i,j)
c               p(i,j,6)=po2(i,j)
c               p(i,j,7)=pcl(i,j)
8       continue

        s=0.
c       do 5 i=1,7
        do 5 i=1,4
          do 7 j=1,6
                var(j) = p(1,j,i)*cos(z) + p(2,j,i)*cos(f) +
     &                   p(3,j,i)*cos(0.013*(300.-fs)) +
     &                   p(4,j,i)*cos(0.52*(t-6.)) + p(5,j,i)
7         continue
          cm(i)  = var(1)
          hm(i)  = var(2)
          all(i) = var(3)
          betl(i)= var(4)
          alh(i) = var(5)
          beth(i)= var(6)
          hx=h-hm(i)
          if(hx) 1,2,3
1               arg = hx * (hx * all(i) + betl(i)) 
                cn(i) = 0.
                if(arg.gt.-argmax) cn(i) = cm(i) * exp( arg )
                goto 4
2               cn(i) = cm(i)
                goto 4
3               arg = hx * (hx * alh(i) + beth(i)) 
                cn(i) = 0.
                if(arg.gt.-argmax) cn(i) = cm(i) * exp( arg )
4         continue
          if(cn(i).LT.0.005*cm(i)) cn(i)=0.
          if(cn(i).GT.cm(i)) cn(i)=cm(i)
          s=s+cn(i)
5       continue
c       do 6 i=1,7
        do 6 i=1,4
6               cn(i)=cn(i)/s*100.
        return
        end
C
C
      Subroutine ionco2(hei,xhi,it,F,R1,R2,R3,R4)
*----------------------------------------------------------------
*     INPUT DATA :
*      hei  -  altitude in km
*      xhi  -  solar zenith angle in degree
*      it   -  seasonal month (Northern Hemisphere January 
*              is ismo=1 and so is Southern Hemisohere July)
*      F    -  10.7cm solar radio flux (12-month running mean)
*     OUTPUT DATA :
*     R1 -  NO+ concentration (in percent)
*     R2 -  O2+ concentration (in percent) 
*     R3 -  Cb+ concentration (in percent) 
*     R4 -  O+  concentration (in percent) 
*
*  A.D. Danilov and N.V. Smirnova, Improving the 75 to 300 km ion 
*  composition model of the IRI, Adv. Space Res. 15, #2, 171-177, 1995.
*
*-----------------------------------------------------------------
      dimension j1ms70(7),j2ms70(7),h1s70(13,7),h2s70(13,7),
     *       R1ms70(13,7),R2ms70(13,7),rk1ms70(13,7),rk2ms70(13,7),
     *       j1ms140(7),j2ms140(7),h1s140(13,7),h2s140(13,7), 
     *       R1ms140(13,7),R2ms140(13,7),rk1ms140(13,7),rk2ms140(13,7),
     *       j1mw70(7),j2mw70(7),h1w70(13,7),h2w70(13,7),
     *       R1mw70(13,7),R2mw70(13,7),rk1mw70(13,7),rk2mw70(13,7),
     *       j1mw140(7),j2mw140(7),h1w140(13,7),h2w140(13,7), 
     *       R1mw140(13,7),R2mw140(13,7),rk1mw140(13,7),rk2mw140(13,7),
     *       j1mr70(7),j2mr70(7),h1r70(13,7),h2r70(13,7),
     *       R1mr70(13,7),R2mr70(13,7),rk1mr70(13,7),rk2mr70(13,7),
     *       j1mr140(7),j2mr140(7),h1r140(13,7),h2r140(13,7), 
     *       R1mr140(13,7),R2mr140(13,7),rk1mr140(13,7),rk2mr140(13,7)
      data j1ms70/11,11,10,10,11,9,11/ 
      data j2ms70/13,11,10,11,11,9,11/
      data h1s70/75,85,90,95,100,120,130,200,220,250,270,0,0,
     *        75,85,90,95,100,120,130,200,220,250,270,0,0, 
     *        75,85,90,95,100,115,200,220,250,270,0,0,0,
     *        75,80,95,100,120,140,200,220,250,270,0,0,0,
     *        75,80,95,100,120,150,170,200,220,250,270,0,0,
     *        75,80,95,100,140,200,220,250,270,0,0,0,0,
     *        75,80,85,95,100,110,145,200,220,250,270,0,0/
      data h2s70/75,80,90,95,100,120,130,140,150,200,220,250,270,
     *        75,80,90,95,100,120,130,200,220,250,270,0,0, 
     *        75,80,90,95,100,115,200,220,250,270,0,0,0,
     *        75,80,95,100,120,140,150,200,220,250,270,0,0,
     *        75,80,95,100,120,150,170,200,220,250,270,0,0,
     *        75,80,95,100,140,200,220,250,270,0,0,0,0,
     *        75,80,90,95,100,110,145,200,220,250,270,0,0/
      data R1ms70/6,30,60,63,59,59,66,52,20,4,2,0,0,
     *         6,30,60,63,69,62,66,52,20,4,2,0,0, 
     *         6,30,60,63,80,68,53,20,4,2,0,0,0,
     *         4,10,60,85,65,65,52,25,12,4,0,0,0, 
     *         4,10,60,89,72,60,60,52,30,20,10,0,0, 
     *         4,10,60,92,68,54,40,25,13,0,0,0,0, 
     *         1,8,20,60,95,93,69,65,45,30,20,0,0/ 
      data R2ms70/4,10,30,32,41,41,32,29,34,28,15,3,1,
     *         4,10,30,32,31,38,32,28,15,3,1,0,0,
     *         4,10,30,32,20,32,28,15,3,1,0,0,0,
     *         2,6,30,15,35,30,34,26,19,8,3,0,0,
     *         2,6,30,11,28,38,29,29,25,12,5,0,0,
     *         2,6,30,8,32,30,20,14,8,0,0,0,0,
     *         1,2,10,20,5,7,31,23,18,15,10,0,0/ 
      data rk1ms70/2.4,6.,.6,-.8,0,.7,-.2,-1.6,-.533,-.1,-.067,0,0,
     *         2.4,6.,.6,1.2,-.35,.4,-.2,-1.6,-.533,-.1,-.067,0,0, 
     *         2.4,6.,.6,3.4,-.8,-.176,-1.65,-.533,-.1,-.067,0,0,0,
     *         1.2,3.333,5.,-1.,0,-.216,-1.35,-.433,-.4,-.1,0,0,0,
     *         1.2,3.333,5.8,-.85,-.4,0,-.267,-1.1,-.333,-.4,-.2,0,0, 
     *         1.2,3.333,6.4,-.6,-.233,-.7,-.5,-.6,-.267,0,0,0,0, 
     *         1.4,2.4,4.,7.,-.2,-.686,-.072,-1.,-.5,-.5,-.5,0,0/
      data rk2ms70/1.2,2.,.4,1.8,0,-.9,-.3,.5,-.12,-.65,-.4,-.1,-.033,
     *         1.2,2.,.4,-.2,.35,-.6,-.057,-.65,-.4,-.1,-.033,0,0,
     *         1.2,2.,.4,-2.4,.8,-.047,-.65,-.4,-.1,-.033,0,0,0,
     *         .8,1.6,-3.,1.,-.25,.4,-.16,-.35,-.367,-.25,-.1,0,0,
     *         .8,1.6,-3.8,.85,.333,-.45,0,-.2,-.433,-.35,-.1,0,0,
     *         .8,1.6,-4.4,.6,-.033,-.5,-.2,-.3,-.2,0,0,0,0,
     *         .2,.8,2.,-3.,.2,.686,-.145,-.25,-.1,-.25,-.2,0,0/
      data j1ms140/11,11,10,10,9,9,12/ 
      data j2ms140/11,11,10,9,10,10,12/
      data h1s140/75,85,90,95,100,120,130,140,200,220,250,0,0,
     *        75,85,90,95,100,120,130,140,200,220,250,0,0,
     *        75,85,90,95,100,120,140,200,220,250,0,0,0,
     *        75,80,95,100,120,140,200,220,250,270,0,0,0,
     *        75,80,95,100,120,200,220,250,270,0,0,0,0,
     *        75,80,95,100,130,200,220,250,270,0,0,0,0,
     *        75,80,85,95,100,110,140,180,200,220,250,270,0/
      data h2s140/75,80,90,95,100,120,130,155,200,220,250,0,0,
     *        75,80,90,95,100,120,130,160,200,220,250,0,0,
     *        75,80,90,95,100,120,165,200,220,250,0,0,0,
     *        75,80,95,100,120,180,200,250,270,0,0,0,0,
     *        75,80,95,100,120,160,200,220,250,270,0,0,0,
     *        75,80,95,100,130,160,200,220,250,270,0,0,0,
     *        75,80,90,95,100,110,140,180,200,220,250,270,0/
      data R1ms140/6,30,60,63,59,59,66,66,38,14,1,0,0,
     *         6,30,60,63,69,62,66,66,38,14,1,0,0,
     *         6,30,60,63,80,65,65,38,14,1,0,0,0,
     *         4,10,60,85,66,66,38,22,9,1,0,0,0,
     *         4,10,60,89,71,42,26,17,10,0,0,0,0,
     *         4,10,60,93,71,48,35,22,10,0,0,0,0,
     *         1,8,20,60,95,93,72,60,58,40,26,13,0/ 
      data R2ms140/4,10,30,32,41,41,30,30,10,6,1,0,0,
     *         4,10,30,32,31,38,31,29,9,6,1,0,0,
     *         4,10,30,32,20,35,26,9,6,1,0,0,0,
     *         2,6,30,15,34,24,10,5,1,0,0,0,0,
     *         2,6,30,11,28,37,21,14,8,5,0,0,0,
     *         2,6,30,7,29,36,29,20,13,5,0,0,0,
     *         1,2,10,20,5,7,28,32,28,20,14,7,0/ 
      data rk1ms140/2.4,6.,.6,-.8,0,.7,0,-.467,-1.2,-.433,0,0,0,
     *         2.4,6.,.6,1.2,-.35,.4,0,-.467,-1.2,-.433,0,0,0,    
     *         2.4,6.,.6,3.4,-.75,0,-.45,-1.2,-.433,0,0,0,0,
     *         1.2,3.333,5.,-.95,0,-.467,-.8,-.433,-.4,0,0,0,0,
     *         1.2,3.333,5.8,-.9,-.363,-.8,-.3,-.35,-.3,0,0,0,0,
     *         1.2,3.333,6.6,-.733,-.329,-.65,-.433,-.6,-.267,0,0,0,0,
     *         1.4,2.4,4.,7.,-.2,-.7,-.3,-.1,-.9,-.467,-.65,-.333,0/
      data rk2ms140/1.2,2.,.4,1.8,0,-1.1,0,-.444,-.2,-.166,0,0,0,
     *         1.2,2.,.4,-.2,.35,-.7,-.067,-.5,-.15,-.166,0,0,0,
     *         1.2,2.,.4,-2.4,.75,-.2,-.486,-.15,-.166,0,0,0,0,
     *         .8,1.6,-3.,.95,-.167,-.7,-.1,-.2,0,0,0,0,0,
     *         .8,1.6,-3.8,.85,.225,-.4,-.35,-.2,-.15,-.133,0,0,0,
     *         .8,1.6,-4.6,.733,.233,-.175,-.45,-.233,-.4,-.1,0,0,0, 
     *         .2,.8,2.,-3.,.2,.7,.1,-.2,-.4,-.2,-.35,-.167,0/
      data j1mr70/12,12,12,9,10,11,13/ 
      data j2mr70/9,9,10,13,12,11,11/
      data h1r70/75,80,90,95,100,120,140,180,200,220,250,270,0,
     *        75,80,90,95,100,120,145,180,200,220,250,270,0, 
     *        75,80,90,95,100,120,145,180,200,220,250,270,0,  
     *        75,95,100,110,140,180,200,250,270,0,0,0,0,
     *        75,95,125,150,185,195,200,220,250,270,0,0,0,
     *        75,95,100,150,160,170,190,200,220,250,270,0,0,
     *        75,80,85,95,100,140,160,170,190,200,220,250,270/
      data h2r70/75,95,100,120,180,200,220,250,270,0,0,0,0,
     *        75,95,100,120,180,200,220,250,270,0,0,0,0, 
     *        75,95,100,120,130,190,200,220,250,270,0,0,0, 
     *        75,80,85,95,100,110,130,180,190,200,220,250,270,
     *        75,80,85,95,100,125,150,190,200,220,250,270,0,
     *        75,80,85,95,100,150,190,200,220,250,270,0,0, 
     *        75,85,95,100,140,180,190,200,220,250,270,0,0/
      data R1mr70/13,17,57,57,30,53,58,38,33,14,6,2,0,
     *         13,17,57,57,37,56,56,38,33,14,6,2,0, 
     *         13,17,57,57,47,58,55,37,33,14,6,2,0, 
     *         5,65,54,58,58,38,33,9,1,0,0,0,0, 
     *         5,65,65,54,40,40,45,26,17,10,0,0,0,    
     *         5,65,76,56,57,48,44,51,35,22,10,0,0, 
     *         3,11,35,75,90,65,63,54,54,50,40,26,13/ 
      data R2mr70/7,43,70,47,15,17,10,4,0,0,0,0,0,
     *         7,43,63,44,17,17,10,4,0,0,0,0,0, 
     *         7,43,53,42,42,13,17,10,4,0,0,0,0,
     *         3,5,26,34,46,42,41,23,16,16,10,1,0,
     *         3,5,26,34,35,35,42,25,22,14,8,5,0, 
     *         3,5,26,34,24,41,31,26,20,13,5,0,0,
     *         3,15,15,10,35,35,30,34,20,14,7,0,0/ 
      data rk1mr70/.8,4.,0,-5.4,1.15,.25,-.5,-.25,-.95,-.267,-.2,
     *             -.067,0,
     *         .8,4.,0,-4.,.95,0,-.514,-.25,-.95,-.267,-.2,-.067,0, 
     *         .8,4.,0,-2.,.55,-.12,-.514,-.2,-.95,-.267,-.2,-.067,0, 
     *         3.,-2.2,.4,0,-.5,-.25,-.48,-.4,-.033,0,0,0,0,   
     *         3.,0,-.44,-.466,0,1.0,-.95,-.3,-.35,-.3,0,0,0, 
     *         3.,2.2,-.4,0.1,-.9,-.2,.7,-.8,-.433,-.6,-.267,0,0, 
     *         1.6,4.8,4.,3.,-.625,-.1,-.9,0,-.4,-.5,-.467,-.65,-.3/
      data rk2mr70/1.8,5.4,-1.15,-.533,.1,-.35,-.2,-.2,0,0,0,0,0,
     *         1.8,4.,-.95,-.45,0,-.35,-.2,-.2,0,0,0,0,0,
     *         1.8,2.,-.55,0,-.483,.4,-.35,-.2,-.2,0,0,0,0,    
     *         .4,4.2,.8,2.4,-.4,-.05,-.36,-.7,0,-.3,-.3,-.05,0,
     *         .4,4.2,.8,.2,0,.28,-.425,-.3,-.4,-.2,-.15,-.133,0,  
     *         .4,4.2,.8,-2.,.34,-.25,-.5,-.3,-.233,-.4,-.1,0,0,  
     *         1.2,0,-1.,.625,0,-.5,.4,-.7,-.2,-.35,-.167,0,0/
      data j1mr140/12,12,11,12,9,9,13/ 
      data j2mr140/10,9,10,12,13,13,12/
      data h1r140/75,80,90,95,100,115,130,145,200,220,250,270,0,
     *        75,80,90,95,100,110,120,145,200,220,250,270,0, 
     *        75,80,90,95,100,115,150,200,220,250,270,0,0,
     *        75,95,100,120,130,140,150,190,200,220,250,270,0,
     *        75,95,120,150,190,200,220,250,270,0,0,0,0,
     *        75,95,100,145,190,200,220,250,270,0,0,0,0,
     *        75,80,85,95,100,120,160,170,190,200,220,250,270/
      data h2r140/75,95,100,115,130,175,200,220,250,270,0,0,0,
     *        75,95,100,110,175,200,220,250,270,0,0,0,0, 
     *        75,95,100,115,130,180,200,220,250,270,0,0,0, 
     *        75,80,85,95,100,120,130,190,200,220,250,270,0,
     *        75,80,85,95,100,120,140,160,190,200,220,250,270,
     *        75,80,85,95,100,145,165,180,190,200,220,250,270,
     *        75,85,95,100,120,145,170,190,200,220,250,270,0/
      data R1mr140/13,17,57,57,28,51,56,56,12,8,1,0,0,
     *         13,17,57,57,36,46,55,56,10,8,1,0,0, 
     *         13,17,57,57,46,56,55,12,8,1,0,0,0,
     *         5,65,54,59,56,56,53,23,16,13,3,1,0,
     *         5,65,65,54,29,16,16,10,2,0,0,0,0,
     *         5,65,76,58,36,25,20,12,7,0,0,0,0,
     *         3,11,35,75,91,76,58,49,45,32,28,20,12/ 
      data R2mr140/7,43,72,49,44,14,7,4,1,0,0,0,0,
     *         7,43,64,51,14,7,4,1,0,0,0,0,0, 
     *         7,43,54,44,44,13,7,4,1,0,0,0,0,
     *         3,5,26,34,46,41,44,9,11,7,2,1,0,
     *         3,5,26,34,35,35,40,40,16,14,9,5,2, 
     *         3,5,26,34,24,40,40,32,19,20,10,7,3,
     *         3,15,15,9,24,35,40,28,28,20,10,8,0/ 
      data rk1mr140/.8,4.,0,-5.8,1.533,.333,0,-.8,-.2,-.233,-.05,0,0,
     *         .8,4.,0,-4.2,1.3,.6,.04,-.836,-.1,-.233,-.05,0,0,
     *         .8,4.,0,-2.2,.667,-.029,-.86,-.2,-.233,-.05,0,0,0,         
     *         3.,-2.2,.25,-.3,0,-.3,-.75,-.7,-.15,-.333,-.1,-.033,0,
     *         3.,0,-.367,-.625,-1.3,0,-.2,-.4,-.067,0,0,0,0, 
     *         3.,2.2,-.4,-.489,-1.1,-.25,-.267,-.25,-.2,0,0,0,0,
     *         1.6,4.8,4.,3.2,-.75,-.45,-.9,-.2,-1.3,-.2,-.267,-.4,-.3/
      data rk2mr140/1.8,5.8,-1.533,-.333,-.667,-.28,-.15,-.1,-.05,
     *              0,0,0,0,
     *         1.8,4.2,-1.3,-.569,-.28,-.15,-.1,-.05,0,0,0,0,0,
     *         1.8,2.2,-.667,0,-.62,-.3,-.15,-.1,-.05,0,0,0,0,    
     *         .4,4.2,.8,2.4,-.25,.3,-.583,.2,-.2,-.167,-.05,-.033,0,
     *         .4,4.2,.8,.02,0,.25,0,-.6,-.2,-.25,-.133,-.15,-.067,  
     *         .4,4.2,.8,-2.,.356,0,-.533,-1.3,.1,-.5,-.1,-.2,-.1,  
     *         1.2,0,-1.2,.75,.44,.2,-.6,0,-.4,-.333,-.1,-.2,0/
      data j1mw70/13,13,13,13,9,8,9/ 
      data j2mw70/10,10,11,11,9,8,11/
      data h1w70/75,80,85,95,100,110,125,145,180,200,220,250,270,
     *        75,80,85,95,100,110,120,150,180,200,220,250,270,
     *        75,80,85,95,100,110,120,155,180,200,220,250,270,
     *        75,80,90,100,110,120,140,160,190,200,220,250,270, 
     *        75,80,90,110,150,200,220,250,270,0,0,0,0,
     *        75,80,90,100,150,200,250,270,0,0,0,0,0,
     *        75,80,90,100,120,130,140,200,270,0,0,0,0/
      data h2w70/75,90,95,100,110,125,190,200,250,270,0,0,0,
     *        75,90,95,100,110,125,190,200,250,270,0,0,0, 
     *        75,90,95,100,110,120,145,190,200,250,270,0,0,
     *        75,80,95,100,110,120,150,200,220,250,270,0,0,
     *        75,80,90,95,110,145,200,250,270,0,0,0,0,
     *        75,80,90,100,140,150,200,250,0,0,0,0,0,
     *        75,80,85,90,100,120,130,140,160,200,270,0,0/ 
      data R1mw70/28,35,65,65,28,44,46,50,25,25,10,5,0,
     *         28,35,65,65,36,49,47,47,25,25,10,5,0,
     *         28,35,65,65,48,54,51,43,25,25,10,5,0,
     *         16,24,66,54,58,50,50,38,25,25,10,5,0, 
     *         16,24,66,66,46,30,20,6,3,0,0,0,0,  
     *         16,24,66,76,49,32,12,7,0,0,0,0,0,      
     *         6,19,67,91,64,68,60,40,12,0,0,0,0/ 
      data R2mw70/5,35,35,72,56,54,12,12,2,0,0,0,0,
     *         5,35,35,64,51,53,12,12,2,0,0,0,0, 
     *         5,35,35,52,46,49,41,12,12,2,0,0,0,
     *         4,10,40,46,42,50,41,12,7,2,0,0,0,
     *         4,10,30,34,34,51,14,4,2,0,0,0,0,
     *         4,10,30,24,45,48,20,5,0,0,0,0,0,
     *         2,6,17,23,9,36,32,40,40,20,6,0,0/ 
      data rk1mw70/1.4,6.,0,-7.4,1.6,.133,.2,-.714,0,-.75,-.167,-.25,0,
     *         1.4,6.,0,-5.8,1.3,-.2,0,-.733,0,-.75,-.167,-.25,0,
     *         1.4,6.,0,-3.4,.6,-.3,-.229,-.72,0,-.75,-.167,-.25,0,
     *         1.6,4.2,-1.2,.4,-.8,0,-.6,-.433,0,-.75,-.167,-.25,0,   
     *         1.6,4.2,0,-.5,-.32,-.5,-.467,-.15,-.1,0,0,0,0,
     *         1.6,4.2,1.,-.54,-.34,-.4,-.25,-.2,0,0,0,0,0,      
     *         2.6,4.8,2.4,-1.35,.4,-.8,-.333,-.4,-.3,0,0,0,0/
      data rk2mw70/2.,0,7.4,-1.6,-.133,-.646,0,-.2,-.1,0,0,0,0,
     *         2.,0,5.8,-1.3,.133,-.631,0,-.2,-.1,0,0,0,0,    
     *         2.,0,3.4,-.6,.3,-.32,-.644,0,-.2,-.1,0,0,0,
     *         1.2,2.,1.2,-.4,.8,-.3,-.58,-.25,-.167,-.1,0,0,0,
     *         1.2,2.,.8,0,.486,-.673,-.2,-.1,-.066,0,0,0,0,  
     *         1.2,2.,-.6,.525,.3,-.56,-.3,-.1,0,0,0,0,0,  
     *         .8,2.2,1.2,-1.4,1.35,-.4,.8,0,-.5,-.2,-.167,0,0/
      data j1mw140/12,11,11,11,11,10,12/ 
      data j2mw140/10,11,11,11,11,10,12/
      data h1w140/75,80,85,95,100,110,125,145,190,200,220,250,0,
     *        75,80,85,95,100,110,120,150,190,220,250,0,0,
     *        75,80,85,95,100,110,120,155,190,220,250,0,0,
     *        75,80,90,100,110,120,140,160,190,220,250,0,0,
     *        75,80,90,110,150,160,190,200,220,250,270,0,0,
     *        75,80,90,100,150,160,190,200,250,270,0,0,0,
     *        75,80,90,100,120,130,140,160,190,200,250,270,0/
      data h2w140/75,90,95,100,110,125,190,200,220,250,0,0,0,
     *        75,90,95,100,110,120,125,190,200,220,250,0,0,
     *        75,90,95,100,110,120,145,190,200,220,250,0,0,  
     *        75,80,95,100,110,120,150,190,200,220,250,0,0,
     *        75,80,90,95,110,145,190,200,220,250,270,0,0,
     *        75,80,90,100,140,150,200,220,250,270,0,0,0,
     *        75,80,85,90,100,120,130,140,160,180,200,220,0/ 
      data R1mw140/28,35,65,65,28,44,46,50,9,6,2,0,0,
     *         28,35,65,65,36,49,47,47,8,2,0,0,0,
     *         28,35,65,65,48,54,51,43,8,2,0,0,0,
     *         16,24,66,54,58,50,50,42,8,2,0,0,0, 
     *         16,24,66,66,46,49,9,10,7,2,0,0,0,
     *         16,24,66,76,49,54,10,14,4,1,0,0,0,
     *         6,19,67,91,64,68,60,58,11,20,5,2,0/ 
      data R2mw140/5,35,35,72,56,54,5,5,1,0,0,0,0,
     *         5,35,35,64,51,53,53,5,5,1,0,0,0,
     *         5,35,35,52,46,49,41,5,5,1,0,0,0,    
     *         4,10,40,46,42,50,41,5,5,1,0,0,0,   
     *         4,10,30,34,34,51,10,5,3,1,0,0,0,  
     *         4,10,30,24,45,48,4,2,1,0,0,0,0,
     *         2,6,17,23,9,36,32,40,39,29,1,0,0/ 
      data rk1mw140/1.4,6.,0,-7.4,1.6,.133,.2,-.911,-.3,-.2,-.066,0,0,
     *         1.4,6.,0,-5.8,1.3,-.2,0,-.975,-.2,-.066,0,0,0,
     *         1.4,6.,0,-3.4,.6,-.3,-.229,-1.,-.2,-.066,0,0,0,
     *         1.6,4.2,-1.2,.4,-.8,0,-.4,-1.133,-.2,-.066,0,0,0,
     *         1.6,4.2,0,-.5,.3,-1.133,.1,-.15,-.166,-.1,0,0,0,
     *         1.6,4.2,1.,-.54,.5,-1.466,.4,-.2,-.15,-.0333,0,0,0,
     *         2.6,4.8,2.4,-1.35,.4,-.8,-.1,-1.566,.9,-.3,-.15,-.05,0/
      data rk2mw140/2.,0,7.4,-1.6,-.133,-.754,0,-.2,-.033,0,0,0,0,
     *         2.,0,5.8,-1.3,.2,0,-.738,0,-.2,-.033,0,0,0,
     *         2.,0,3.4,-.6,.3,-.32,-.8,0,-.2,-.033,0,0,0,
     *         1.2,2.,1.2,-.4,.8,-.3,-.9,0,-.2,-.033,0,0,0,
     *         1.2,2.,.8,0,.486,-.911,-.5,-.1,-.066,-.05,0,0,0,
     *         1.2,2.,-.6,.525,.3,-.88,-.1,-.033,-.05,0,0,0,0,
     *         .8,2.2,1.2,-1.4,1.35,-.4,.8,-.05,-.5,-1.4,-.05,0,0/

        h = hei
        z = xhi

         if(z.lt.20)z=20
         if(z.gt.90)z=90
        if((it.eq.1).or.(it.eq.2).or.(it.eq.11).or.(it.eq.12))then
         if(f.lt.140)then
           Call aprok(j1mw70,j2mw70,h1w70,h2w70,R1mw70,R2mw70,        
     *                rk1mw70,rk2mw70,h,z,R1,R2) 
           R170=R1
           R270=R2
           endif
         if(f.gt.70)then
           Call aprok(j1mw140,j2mw140,h1w140,h2w140,R1mw140,R2mw140,        
     *                rk1mw140,rk2mw140,h,z,R1,R2) 
           R1140=R1
           R2140=R2
           endif
         if((f.gt.70).and.(f.lt.140))then
           R1=R170+(R1140-R170)*(f-70)/70
           R2=R270+(R2140-R270)*(f-70)/70
           endif
         endif
        if((it.eq.5).or.(it.eq.6).or.(it.eq.7).or.(it.eq.8))then
         if(f.lt.140)then
           Call aprok(j1ms70,j2ms70,h1s70,h2s70,R1ms70,R2ms70,        
     *                rk1ms70,rk2ms70,h,z,R1,R2) 
           R170=R1
           R270=R2
           endif
         if(f.gt.70)then
           Call aprok(j1ms140,j2ms140,h1s140,h2s140,R1ms140,R2ms140,        
     *                rk1ms140,rk2ms140,h,z,R1,R2) 
           R1140=R1
           R2140=R2
           endif
         if((f.gt.70).and.(f.lt.140))then
           R1=R170+(R1140-R170)*(f-70)/70
           R2=R270+(R2140-R270)*(f-70)/70
           endif
         endif
        if((it.eq.3).or.(it.eq.4).or.(it.eq.9).or.(it.eq.10))then
         if(f.lt.140)then
           Call aprok(j1mr70,j2mr70,h1r70,h2r70,R1mr70,R2mr70,        
     *                rk1mr70,rk2mr70,h,z,R1,R2) 
           R170=R1
           R270=R2
           endif
         if(f.gt.70)then
           Call aprok(j1mr140,j2mr140,h1r140,h2r140,R1mr140,R2mr140,
     *                rk1mr140,rk2mr140,h,z,R1,R2) 
           R1140=R1
           R2140=R2
           endif
         if((f.gt.70).and.(f.lt.140))then
           R1=R170+(R1140-R170)*(f-70)/70
           R2=R270+(R2140-R270)*(f-70)/70
           endif
         endif
        R3=0
        R4=0
        if (h.lt.100) R3=100-(R1+R2)
        if (h.ge.100) R4=100-(R1+R2)
         if(R3.lt.0) R3=0
         if(R4.lt.0) R4=0
        R1=ANINT(R1)
        R2=ANINT(R2)
        R3=ANINT(R3)
        R4=ANINT(R4)
 300   continue
        end
c
c
      Subroutine aprok(j1m,j2m,h1,h2,R1m,R2m,rk1m,rk2m,hei,xhi,R1,R2)
c----------------------------------------------------------------- 
      dimension   zm(7),j1m(7),j2m(7),h1(13,7),h2(13,7),R1m(13,7),
     *            R2m(13,7),rk1m(13,7),rk2m(13,7)
      data        zm/20,40,60,70,80,85,90/
      
        h=hei
        z=xhi

         j1=1
         j2=1
         i1=1
       do 1 i=1,7
         i1=i
        if(z.eq.zm(i)) j1=0
        if(z.le.zm(i)) goto 11
 1     continue
 11    continue
          i2=1
         do 2 i=2,j1m(i1)
          i2=i-1
          if(h.lt.h1(i,i1)) goto 22
          i2=j1m(i1)
 2       continue
 22      continue
          i3=1
         do 3 i=2,j2m(i1)
          i3=i-1
          if(h.lt.h2(i,i1)) goto 33
          i3=j2m(i1)
 3       continue
 33      continue
        R01=R1m(i2,i1)
        R02=R2m(i3,i1)
        rk1=rk1m(i2,i1)
        rk2=rk2m(i3,i1)
        h01=h1(i2,i1)
        h02=h2(i3,i1)
        R1=R01+rk1*(h-h01)
        R2=R02+rk2*(h-h02)
        if(j1.eq.1)then
          j1=0
          j2=0
          i1=i1-1
          R11=R1
          R12=R2
          goto 11
        endif
        if(j2.eq.0)then
          rk=(z-zm(i1))/(zm(i1+1)-zm(i1)) 
          R1=R1+(R11-R1)*rk
          R2=R2+(R12-R2)*rk
        endif
       end
c
c
	SUBROUTINE CALION(CRD,INVDIP,FL,DIMO,B0,
     &                    DIPL,MLT,ALT,DDD,F107,NO,NH,NHE,NN)
C----------------------------------------------------------------------
C Version 1.0 (released 20.12.2002)
C CALION calculates relative density of O+, H+, He+ and N+  in the outer
C ionosphere with regard to solar activity (F107 index).
C CALION uses subroutines IONLOW and IONHIGH.
C Linearly interpolates for solar activity.
C Inputs: CRD - 0 .. INVDIP
C               1 .. FL, DIMO, B0, DIPL (used for calculation INVDIP inside)
C         INVDIP - "mix" coordinate of the dip latitude and of
C                    the invariant latitude;
C                    positive northward, in deg, range <-90.0;90.0>
C         FL, DIMO, B0 - McIlwain L parameter, dipole moment in
C                        Gauss, magnetic field strength in Gauss -
C                        parameters needed for invariant latitude
C                        calculation
C         DIPL - dip latitude
C                positive northward, in deg, range <-90.0;90.0>
C         MLT - magnetic local time (central dipole)
C               in hours, range <0;24)
C         ALT - altitude above the Earth's surface;
C               in km, range <350;2000>
C         DDD - day of year; range <0;365>
C         F107 - F107 index
C Output: NO,NH,NHE,NN - relative density of O+, H+, He+, and N+
C Versions:  1.0 FORTRAN
C
C REFERENCES:
C   Triskova, L., Truhlik, V., Smilauer, J. An empirical model of ion
C      composition in the outer ionosphere. Adv. Space Res. 31 (3), 
C      653–663, 2003.
C   Truhlik, V., Triskova, L., Smilauer, J. New advances in empirical
C      modeling of ion composition in the outer ionosphere. Adv. Space
C      Res. 33, 844–849, 2004.
C
C Author of the code:
C         Vladimir Truhlik
C         Institute of Atm. Phys.
C         Bocni II.
C         141 31 Praha 4, Sporilov
C         Czech Republic
C         e-mail: vtr@ufa.cas.cz
C         tel/fax: +420 267103058, +420 728073539 / +420 272 762528
C----------------------------------------------------------------------
      REAL INVDIP,FL,DIMO,B0,DIPL,MLT,ALT,F107
	INTEGER CRD,DDD,ION
      REAL NO,NH,NHE,NN,NOH,NHH,NHEH,NNH,NOL,NHL,NHEL,NNL,NTOT
      DIMENSION  DOL(3,3,49),DHL(3,3,49),DHEL(3,3,49),DNL(3,3,49)
      DIMENSION  DOH(4,3,49),DHH(4,3,49),DHEH(4,3,49),DNH(4,3,49)
C/////////////////////coefficients high solar activity////////////////////////
C//////////////////////////////////O+/////////////////////////////////////////
C     550km equinox
      DATA (DOH(1,1,J),J=1,49)/-1.2838E-002, 3.3892E-009,-4.9527E-003,
     &                        9.6584E-009,-2.8249E-004, 9.2209E-009,
     &                       -1.5708E-003,-1.5997E-003,-1.7077E-010,
     &                        6.0805E-004,-3.2035E-009, 4.6574E-004,
     &                       -3.0838E-009,-1.7719E-003, 1.7746E-009,
     &                        2.0281E-003, 5.9550E-010,-8.4087E-004,
     &                        7.3645E-010, 1.6083E-003,-1.9020E-010,
     &                       -5.6389E-004, 2.1437E-010,-9.1530E-005,
     &                       -8.1471E-004,-1.4259E-009,-5.3451E-004,
     &                       -6.4989E-010, 9.7174E-005,-9.1365E-004,
     &                        3.6711E-010,-2.8037E-005, 7.6651E-011,
     &                        1.5422E-003, 1.4647E-010,-1.7107E-005,
     &                        2.1872E-010, 1.4265E-004, 6.1624E-010,
     &                        1.2512E-004, 4.8548E-004,-1.6132E-010,
     &                       -1.4022E-005,-1.1307E-004, 1.6024E-010,
     &                        2.7979E-004, 6.1773E-011,-2.7536E-005,
     &                        3.7412E-005/
C     550km June solstice
      DATA (DOH(1,2,J),J=1,49)/-1.3612E-002,-5.5550E-003,-8.8001E-003,
     &                       -6.7878E-003,-2.5424E-003,-6.6143E-004,
     &                       -3.0189E-003,-5.1701E-004,-3.4954E-004,
     &                       -2.9469E-005, 4.0382E-005, 3.1389E-006,
     &                        5.8065E-005, 1.6808E-003,-2.0046E-004,
     &                        1.1039E-003, 1.0451E-003,-1.0243E-004,
     &                       -1.6330E-004, 1.3405E-003,-4.0310E-004,
     &                        2.9640E-004, 3.3187E-004, 1.5748E-004,
     &                       -1.0201E-003,-3.4733E-004,-1.8801E-004,
     &                        1.3370E-004,-3.8261E-005, 2.5237E-004,
     &                        9.9983E-005, 5.3315E-005, 6.1462E-005,
     &                       -2.2161E-004, 3.8285E-004, 3.6890E-005,
     &                       -2.8965E-006,-2.6102E-005, 2.1884E-005,
     &                        5.6101E-005, 3.2898E-004, 4.8422E-005,
     &                        8.9837E-007, 2.0305E-005, 1.3643E-005,
     &                        1.1488E-004, 4.8798E-005,-1.7122E-006,
     &                        1.3591E-004/
C     900km equinox
      DATA (DOH(2,1,J),J=1,49)/-1.1873E-001,-7.9543E-008, 8.8754E-002,
     &                        1.2749E-007, 3.7834E-002,-3.7071E-008,
     &                       -3.3659E-002,-1.3753E-001,-6.7705E-008,
     &                       -7.8370E-003, 5.0045E-008, 1.7354E-002,
     &                       -1.2451E-008,-5.5262E-002,-1.6397E-008,
     &                        9.0203E-003,-3.1764E-009, 3.2200E-004,
     &                        4.4309E-009,-4.7726E-002,-1.6271E-008,
     &                       -1.6568E-002, 8.7942E-009, 3.9707E-003,
     &                       -1.3873E-002,-1.3387E-008,-5.5410E-003,
     &                        3.2760E-009, 1.5026E-003, 5.4130E-004,
     &                       -4.3665E-009,-8.5634E-003, 2.2732E-009,
     &                       -7.3394E-003,-9.4292E-009,-4.1713E-003,
     &                        2.0113E-009, 2.5152E-003,-1.4286E-010,
     &                       -2.7636E-003, 1.4591E-003,-3.7848E-009,
     &                       -2.1361E-003,-1.7300E-003,-6.3066E-012,
     &                       -1.8190E-003,-1.1929E-009,-2.4384E-003,
     &                        4.5096E-003/
C     900km June solstice
      DATA (DOH(2,2,J),J=1,49)/-1.1400E-001, 7.2284E-002, 5.9514E-002,
     &                       -9.2827E-002, 2.4670E-002, 1.8185E-002,
     &                       -5.3528E-003,-1.0798E-001, 4.9821E-002,
     &                       -5.4609E-003,-7.3866E-003, 5.5822E-003,
     &                       -2.2066E-003,-9.4552E-003,-7.0287E-003,
     &                        1.5038E-002,-4.9536E-003,-2.1970E-003,
     &                        1.8018E-003,-5.1372E-002, 1.5935E-002,
     &                       -7.7984E-004,-9.8830E-004,-6.1488E-004,
     &                       -5.4875E-003,-6.8829E-003, 9.0910E-003,
     &                       -3.6180E-003, 4.6157E-004,-3.7871E-003,
     &                       -9.0714E-005, 6.0385E-004, 1.6097E-004,
     &                       -7.2617E-003,-1.9084E-003, 3.5375E-003,
     &                       -8.3529E-004,-7.7380E-003, 1.0796E-004,
     &                        5.0314E-004,-1.3759E-002, 5.3603E-004,
     &                        6.4259E-004,-6.4764E-003,-1.6915E-004,
     &                       -7.3788E-003, 3.5767E-004,-3.8287E-003,
     &                       -3.2403E-003/
C     1500km equinox
      DATA (DOH(3,1,J),J=1,49)/-5.0096E-001, 3.9699E-007, 5.4222E-001,
     &                       -4.2933E-007, 4.2261E-002,-1.2006E-007,
     &                       -1.3304E-001,-5.7614E-001, 1.9950E-007,
     &                        4.2972E-002,-3.6102E-008, 3.6207E-002,
     &                       -8.1212E-009,-3.0608E-001, 7.6853E-008,
     &                        6.8090E-002,-5.5044E-008,-4.6984E-003,
     &                        2.6068E-008,-1.5518E-001,-2.0579E-008,
     &                       -2.1672E-002, 9.6017E-009, 7.6241E-003,
     &                       -1.5461E-001, 3.9902E-008, 3.9501E-003,
     &                       -9.3205E-009, 3.6564E-003,-1.8591E-002,
     &                       -1.5121E-008,-1.0493E-002, 5.6094E-009,
     &                        2.3030E-002,-4.0654E-008,-6.5416E-004,
     &                        1.2860E-010,-3.5348E-002, 1.1426E-008,
     &                       -4.0794E-003, 2.4538E-002,-2.8703E-008,
     &                        1.1241E-003, 3.0503E-003, 7.4212E-010,
     &                       -9.1099E-003,-6.3420E-009,-2.4364E-003,
     &                        7.8412E-003/
C     1500km June solstice
      DATA (DOH(3,2,J),J=1,49)/-3.8369E-001, 2.8162E-001, 3.3410E-001,
     &                       -4.4591E-001, 1.2217E-001, 1.4901E-001,
     &                       -1.2365E-001,-3.3668E-001, 1.4641E-001,
     &                        1.5156E-002,-4.2536E-002, 2.6524E-002,
     &                       -5.5077E-003,-1.1957E-001, 6.0421E-002,
     &                       -3.9161E-003,-1.0382E-002, 1.1853E-002,
     &                       -7.9129E-003, 5.4055E-002,-3.9953E-002,
     &                        7.1875E-003, 6.0955E-003,-3.0049E-003,
     &                       -4.5588E-003,-7.0102E-003, 8.8947E-005,
     &                        4.6705E-003,-1.5544E-003, 5.2816E-002,
     &                       -3.2857E-002, 7.5772E-003, 3.3781E-004,
     &                        5.3629E-002,-2.2430E-002, 2.4118E-003,
     &                        3.1271E-004,-1.4393E-002,-6.6816E-003,
     &                        1.7099E-003, 4.2075E-003,-2.0012E-003,
     &                       -6.8627E-004,-1.6996E-002, 1.9841E-003,
     &                       -1.0077E-002,-4.0022E-004,-3.5827E-003,
     &                        1.0792E-003/
C     2250km equinox
      DATA (DOH(4,1,J),J=1,49)/-7.5121E-001, 4.7106E-006, 9.8731E-001,
     &                       -1.1517E-005,-2.1953E-001, 7.7259E-006,
     &                       -7.3014E-002,-3.4116E-001,-1.3414E-006,
     &                        3.8833E-002,-6.9663E-007, 1.0871E-002,
     &                        5.1607E-007,-5.2445E-001, 1.5335E-006,
     &                        1.1675E-001,-9.3384E-007,-8.9381E-003,
     &                        1.5077E-007,-4.9602E-003,-6.4438E-007,
     &                       -1.0283E-002,-3.9542E-008, 1.7114E-003,
     &                       -1.1767E-001, 2.1163E-007,-1.4566E-003,
     &                       -2.4207E-007, 1.9790E-003,-8.8082E-003,
     &                       -4.2416E-008, 1.0644E-003,-2.3959E-009,
     &                        9.4817E-002,-7.9695E-007,-4.1841E-003,
     &                       -5.9703E-008, 4.2488E-002, 4.4664E-008,
     &                        1.6134E-003, 4.5698E-002,-2.0829E-007,
     &                       -1.2046E-003,-1.0719E-004, 1.8530E-007,
     &                        8.5126E-003, 4.9934E-008, 7.7988E-003,
     &                        1.4431E-003/
C     2250km June solstice
      DATA (DOH(4,2,J),J=1,49)/-8.2190E-001, 3.6727E-001, 8.6943E-001,
     &                       -5.1681E-001, 4.3418E-002, 1.4628E-001,
     &                       -1.6190E-001,-4.8689E-001, 7.9939E-002,
     &                        2.9131E-002, 9.4168E-003, 1.6115E-002,
     &                       -1.1809E-002,-4.8438E-001, 1.0166E-001,
     &                        1.2800E-001,-6.1316E-002,-1.6983E-002,
     &                        1.4167E-002, 3.5405E-003,-7.8288E-003,
     &                       -3.2292E-003, 8.7041E-003,-3.6171E-003,
     &                       -1.5451E-001,-1.1808E-002, 2.8659E-002,
     &                       -2.7932E-004,-2.7786E-003, 1.5649E-001,
     &                       -4.8513E-003,-2.4998E-003,-9.9171E-004,
     &                       -8.0071E-002,-2.4185E-003, 6.4073E-003,
     &                       -2.6383E-004,-4.7954E-003,-8.6720E-003,
     &                        1.5965E-003,-7.1514E-003, 7.0614E-003,
     &                       -1.8408E-003,-1.1994E-002,-4.7379E-003,
     &                       -2.0841E-002,-2.9637E-003,-4.9867E-003,
     &                       -1.4069E-002/
C//////////////////////////////////////////////////////////////////////
C//////////////////////////////////H+//////////////////////////////////
C     550km equinox
      DATA (DHH(1,1,J),J=1,49)/-3.1678E+000, 3.6289E-007,-5.5819E-002,
     &                       -1.0303E-006,-1.1119E-001,-1.7286E-007,
     &                        2.9466E-002, 6.9927E-001,-1.0867E-007,
     &                       -3.8446E-002,-3.1427E-008, 1.4009E-002,
     &                        4.5348E-008, 2.6142E-001, 9.8583E-008,
     &                       -1.5370E-002,-8.8257E-008, 1.1618E-002,
     &                        9.8907E-008,-5.4724E-002, 2.2519E-007,
     &                        1.5621E-002,-1.0045E-008, 3.6467E-003,
     &                       -1.2359E-001, 4.9284E-008,-1.1143E-002,
     &                        2.3898E-009,-5.8604E-003,-1.0020E-003,
     &                       -1.1869E-007,-8.7861E-004,-1.0543E-008,
     &                        9.8818E-002, 7.4183E-008, 1.3692E-002,
     &                       -1.6456E-008,-3.8041E-002, 3.5978E-008,
     &                       -3.9582E-003, 2.8077E-002,-2.2537E-008,
     &                        1.5597E-003,-3.7610E-003,-2.4712E-008,
     &                        4.0460E-003, 7.7021E-009,-1.4101E-003,
     &                        1.6789E-002/
C     550km June solstice
      DATA (DHH(1,2,J),J=1,49)/-2.8141E+000,-4.4836E-001, 8.2760E-003,
     &                        1.9407E-001, 2.8119E-002,-2.6308E-002,
     &                       -1.5432E-002, 4.8983E-001, 8.6385E-002,
     &                       -7.5200E-002, 1.8661E-002, 4.9780E-003,
     &                       -1.6762E-002, 1.8896E-001,-8.6811E-002,
     &                        5.1824E-004,-6.4436E-003, 3.5544E-003,
     &                        9.4714E-003, 2.0099E-002, 1.9941E-002,
     &                        2.5581E-002,-5.2659E-003,-3.4378E-003,
     &                       -1.2902E-001, 1.4578E-002,-2.5016E-003,
     &                       -2.0760E-002, 3.4195E-003,-8.2338E-002,
     &                        5.0698E-003,-3.4081E-004,-2.7512E-003,
     &                       -4.0443E-002, 2.2658E-003,-8.0779E-003,
     &                       -3.1290E-003,-1.5350E-003, 2.5313E-003,
     &                       -3.4740E-003, 8.2225E-003,-2.6921E-003,
     &                        1.3247E-003, 5.7483E-003, 4.0066E-003,
     &                        1.3048E-002, 1.6612E-004, 6.5345E-003,
     &                        6.1813E-003/
C     900km equinox
      DATA (DHH(2,1,J),J=1,49)/-1.5293E+000, 1.9563E-007,-7.1593E-001,
     &                        5.0551E-008,-1.0967E-001, 1.4302E-007,
     &                        2.3166E-001, 7.0241E-001, 6.7276E-008,
     &                       -3.9113E-003,-2.3431E-008,-2.9279E-002,
     &                       -2.1680E-008, 3.0214E-001, 8.5569E-008,
     &                       -5.9577E-002,-7.4572E-008, 1.3847E-002,
     &                        1.9007E-008, 9.1829E-002,-8.0079E-008,
     &                        2.6453E-002, 2.1214E-008,-3.2018E-003,
     &                       -2.1978E-001, 1.7330E-009,-1.1862E-003,
     &                        2.2427E-008, 1.3491E-003, 2.8588E-002,
     &                       -5.3489E-008, 1.1135E-002,-1.3678E-009,
     &                        7.9619E-002, 1.5714E-008, 7.1930E-003,
     &                        2.9905E-009,-3.8042E-002, 1.1725E-008,
     &                        3.4274E-003,-4.9647E-003, 2.1675E-009,
     &                        7.9079E-003,-7.9338E-003, 3.6623E-008,
     &                        8.5068E-004, 1.7537E-009, 2.3308E-002,
     &                       -2.1869E-002/
C     900km June solstice
      DATA (DHH(2,2,J),J=1,49)/-1.3652E+000,-3.7141E-001,-6.9554E-001,
     &                        2.1456E-001, 9.1424E-002, 4.0012E-002,
     &                        9.3601E-002, 4.8116E-001, 3.2264E-002,
     &                        6.8285E-002, 9.8315E-003,-3.4080E-003,
     &                       -1.1225E-003, 1.2620E-001, 3.3225E-002,
     &                       -4.8420E-002,-2.8323E-002,-2.2914E-003,
     &                        7.9720E-003, 1.2455E-001,-4.2949E-002,
     &                       -5.3643E-003, 6.7441E-003, 1.4582E-002,
     &                       -4.0379E-002, 3.8848E-002,-3.2937E-003,
     &                        9.1013E-003,-7.5494E-003,-6.2580E-002,
     &                        1.1877E-002,-4.8900E-003,-5.3770E-003,
     &                        1.5066E-002,-9.2034E-004,-7.2370E-003,
     &                       -3.5355E-004, 8.6705E-003, 1.0198E-002,
     &                        2.0618E-003, 5.7210E-002, 6.8151E-003,
     &                       -1.8874E-003, 1.7634E-002, 9.8946E-003,
     &                        1.8101E-002, 5.3287E-003, 3.0321E-002,
     &                        6.8488E-003/
C     1500km equinox
      DATA (DHH(3,1,J),J=1,49)/-8.1841E-001, 1.3246E-007,-9.9407E-001,
     &                       -3.5826E-007,-1.1572E-001,-3.8968E-007,
     &                        1.8954E-001, 2.6643E-001,-1.2399E-008,
     &                        2.2029E-002, 3.5262E-008,-2.5895E-002,
     &                        2.5542E-008, 1.7279E-001,-1.0393E-008,
     &                       -3.0719E-002,-6.3703E-009, 7.5848E-003,
     &                       -1.4497E-008, 9.7870E-002,-1.3003E-007,
     &                       -2.0224E-003,-3.9366E-008,-3.2416E-003,
     &                        1.5904E-002,-1.5451E-008,-3.5652E-003,
     &                       -1.3658E-009,-7.7126E-003,-1.5924E-002,
     &                        1.6773E-008,-3.7276E-003, 1.7795E-008,
     &                        7.4727E-003, 3.0856E-008, 7.4715E-004,
     &                        7.3372E-009, 1.3716E-002, 4.6691E-008,
     &                        4.0197E-003,-1.1936E-002, 5.8220E-009,
     &                        3.8995E-003, 7.2715E-003,-2.0243E-008,
     &                        4.1793E-003,-3.2785E-009, 1.3978E-002,
     &                       -6.1225E-003/
C     1500km June solstice
      DATA (DHH(3,2,J),J=1,49)/-8.1500E-001,-3.1034E-001,-1.0382E+000,
     &                        2.2304E-001,-1.3799E-001, 6.2362E-002,
     &                        2.6902E-001, 2.6612E-001,-4.7466E-002,
     &                        1.9184E-002,-7.0576E-002,-1.7642E-002,
     &                        1.4685E-002, 7.7755E-002,-3.1315E-002,
     &                        1.9684E-002,-1.3324E-002, 3.4012E-003,
     &                        3.7043E-002,-1.8646E-002, 2.6457E-002,
     &                        9.8637E-003, 2.6819E-003, 1.7598E-003,
     &                       -2.1755E-002, 4.2552E-003,-1.6633E-002,
     &                       -6.7044E-003, 3.4964E-003,-4.8719E-003,
     &                        5.9790E-003, 2.3021E-005, 5.4778E-003,
     &                       -1.2598E-002, 9.9962E-003,-1.0507E-003,
     &                        5.7994E-003, 2.0765E-002, 1.1593E-002,
     &                       -3.2365E-004,-1.5353E-003, 1.4942E-003,
     &                        1.9642E-003, 8.8836E-003, 4.2172E-003,
     &                       -1.8502E-004, 2.3092E-003, 1.8370E-003,
     &                       -3.7978E-004/
C     2250km equinox
      DATA (DHH(4,1,J),J=1,49)/-6.6978E-001, 4.5698E-007,-1.2361E+000,
     &                       -1.5676E-007,-1.2804E-001,-6.0241E-007,
     &                        2.7591E-001, 4.0136E-002,-1.1570E-007,
     &                        2.1493E-002,-4.5863E-008, 2.6574E-003,
     &                        1.7588E-008, 1.5964E-001, 1.2470E-007,
     &                        1.8918E-002, 9.3632E-008,-2.4488E-003,
     &                        2.0725E-008, 6.6975E-002, 1.1782E-008,
     &                        1.9413E-002, 6.2877E-009, 5.3689E-003,
     &                       -1.5363E-002,-2.0022E-009,-2.1002E-002,
     &                       -6.7078E-009,-2.9894E-003, 6.1202E-003,
     &                        1.2119E-008,-2.2888E-003, 4.3298E-009,
     &                       -4.6405E-002,-5.8474E-008,-3.6078E-003,
     &                       -1.6963E-008,-1.8254E-002,-1.0377E-009,
     &                       -1.3715E-003,-2.2111E-003, 3.4185E-009,
     &                        9.5343E-004,-2.2094E-003, 2.7066E-009,
     &                       -2.4215E-003,-3.1546E-009,-1.0581E-003,
     &                       -1.0098E-003/
C     2250km June solstice
      DATA (DHH(4,2,J),J=1,49)/-5.6899E-001,-2.5609E-001,-1.0606E+000,
     &                       -1.6164E-002,-1.9427E-001, 1.0428E-001,
     &                        1.9448E-001, 1.1527E-001, 1.6518E-002,
     &                        3.6148E-002,-7.0688E-003, 1.0841E-002,
     &                        3.6512E-003, 1.0339E-001,-2.1704E-003,
     &                       -7.0271E-003, 1.9422E-002, 4.1677E-003,
     &                       -6.6189E-003, 4.3364E-002,-2.5002E-002,
     &                        1.4219E-002,-2.2654E-003, 5.6440E-003,
     &                       -3.7866E-002, 1.0338E-004,-3.9639E-003,
     &                       -3.3311E-003,-3.3289E-004,-5.2423E-002,
     &                        2.5430E-003,-7.1279E-003, 3.2787E-003,
     &                        5.9375E-003, 7.2932E-003,-1.9167E-003,
     &                       -1.8983E-003, 4.5326E-003, 6.8099E-003,
     &                       -7.4999E-005,-7.8634E-003,-5.5813E-003,
     &                       -5.3892E-004, 8.5280E-004, 1.4028E-003,
     &                        3.5032E-003,-3.7237E-004,-2.5767E-005,
     &                       -8.0710E-004/
C//////////////////////////////////////////////////////////////////////
C//////////////////////////////////He+/////////////////////////////////
C     550km equinox
      DATA (DHEH(1,1,J),J=1,49)/-3.0827E+000, 4.4643E-007,-3.4361E-001,
     &                       -4.7996E-007,-2.9473E-001, 1.5576E-007,
     &                        2.0815E-001, 4.0991E-001,-2.9466E-008,
     &                       -5.9793E-002, 3.8185E-008, 2.5958E-002,
     &                       -5.2957E-008, 6.6694E-001, 1.1803E-007,
     &                       -2.9476E-002, 1.4225E-008,-1.3761E-002,
     &                       -7.2518E-008,-2.8967E-001,-2.0293E-008,
     &                        1.8383E-002, 1.0666E-008,-9.8637E-003,
     &                       -2.1268E-001, 4.3123E-008,-1.3389E-002,
     &                        2.6780E-009, 9.9442E-004,-7.8858E-003,
     &                        5.6098E-009,-4.9395E-003,-4.3890E-010,
     &                       -8.3089E-002, 5.4720E-008, 1.4305E-002,
     &                       -9.3089E-009,-6.8383E-003,-7.1157E-009,
     &                       -3.9638E-003, 9.9653E-003, 1.0788E-008,
     &                       -1.1729E-003,-2.9558E-003, 1.6849E-008,
     &                        1.2213E-003,-8.7021E-009,-1.4505E-002,
     &                       -5.6113E-004/
C     550km June solstice
      DATA (DHEH(1,2,J),J=1,49)/-2.9760E+000,-8.6799E-001, 4.8259E-002,
     &                        4.8124E-001,-9.2323E-003,-1.7802E-001,
     &                        1.2279E-001, 1.6776E-001, 2.1054E-001,
     &                       -5.1912E-002,-1.0298E-002, 1.5834E-002,
     &                       -8.3905E-003, 1.5721E-001,-2.7260E-002,
     &                       -6.7125E-002,-3.9449E-002, 4.7324E-003,
     &                        1.0327E-002,-1.8399E-001, 2.0860E-002,
     &                        4.3145E-002,-4.9043E-003,-5.6411E-003,
     &                       -2.4448E-001, 7.1468E-002,-1.2413E-002,
     &                       -1.3358E-002,-2.2098E-003,-3.9760E-002,
     &                       -7.9188E-003, 6.9939E-004,-5.3921E-003,
     &                       -5.5414E-002, 8.5107E-003,-9.8890E-003,
     &                        5.1361E-004, 6.6272E-002,-2.5510E-003,
     &                       -7.3423E-003, 2.0118E-003,-6.4885E-003,
     &                        2.7256E-003, 8.6778E-003,-8.9810E-004,
     &                        1.0350E-002,-3.1749E-003, 1.6338E-002,
     &                       -2.1051E-003/
C     900km equinox
      DATA (DHEH(2,1,J),J=1,49)/-1.7100E+000, 5.2540E-007,-8.2280E-001,
     &                       -8.2344E-007,-4.0545E-001,-5.5031E-007,
     &                        3.3911E-001, 2.5554E-001, 8.4842E-008,
     &                        8.3244E-002, 9.6193E-008,-6.0073E-002,
     &                       -2.0823E-007, 3.0060E-001, 7.9876E-008,
     &                       -1.1750E-001,-2.9524E-008,-3.5514E-002,
     &                       -2.9102E-008,-4.5851E-002,-4.7236E-009,
     &                        2.4348E-002, 4.2832E-009,-7.4072E-003,
     &                       -1.1252E-001, 9.5787E-008, 2.6864E-002,
     &                        1.7685E-008,-5.9893E-003,-1.6605E-001,
     &                       -1.3665E-007, 1.2534E-002, 1.1691E-008,
     &                        4.7303E-002, 6.8012E-010, 1.0472E-002,
     &                        1.9695E-009,-8.2855E-003,-8.1465E-009,
     &                        5.7602E-003, 7.8478E-003,-2.5233E-008,
     &                        3.0308E-003,-8.5876E-003, 2.5667E-009,
     &                        6.5844E-003,-1.7771E-008,-6.1409E-003,
     &                       -1.0949E-002/
C     900km June solstice
      DATA (DHEH(2,2,J),J=1,49)/-2.0393E+000,-8.1007E-001,-4.3286E-001,
     &                        3.0351E-001,-1.7024E-001, 4.6307E-002,
     &                       -2.4220E-003,-6.3442E-002,-1.6370E-003,
     &                        6.7460E-002,-1.0338E-002,-4.4583E-002,
     &                        9.6863E-003, 5.3744E-003, 2.6359E-003,
     &                       -5.8995E-002,-1.6310E-002, 7.3342E-003,
     &                        9.4701E-004, 6.9508E-002,-4.3418E-002,
     &                       -5.1968E-003,-3.0680E-003, 1.1837E-002,
     &                       -1.2321E-001, 4.2603E-002,-3.5437E-002,
     &                        1.6518E-002,-1.2969E-002, 3.2534E-002,
     &                        2.8450E-003, 3.5741E-003,-2.0381E-003,
     &                       -5.0507E-002, 8.2961E-003, 3.8507E-004,
     &                        1.0441E-003, 4.1571E-002,-2.9669E-003,
     &                       -7.7910E-004, 2.2211E-002,-3.5130E-003,
     &                        2.3044E-003, 2.9926E-002, 2.6085E-003,
     &                        2.5759E-002, 3.9804E-004, 3.1126E-002,
     &                        1.0860E-002/
C     1500km equinox
      DATA (DHEH(3,1,J),J=1,49)/-1.2078E+000,-8.3889E-008,-8.6323E-001,
     &                       -1.5199E-007,-4.4768E-001, 2.5090E-007,
     &                        3.5311E-001, 1.3210E-001,-4.2130E-009,
     &                       -2.5480E-003, 3.0688E-008,-4.3178E-002,
     &                        1.8903E-009, 8.9046E-002,-1.0776E-008,
     &                        2.9388E-002, 2.2664E-008,-1.1335E-002,
     &                       -1.4036E-008,-4.9870E-002,-2.0597E-008,
     &                        5.1163E-003, 1.5444E-008, 7.0597E-003,
     &                       -1.1044E-001, 3.2974E-008, 3.3729E-002,
     &                        9.6660E-009,-2.0066E-002,-4.7281E-002,
     &                        1.0175E-008, 4.5853E-003, 3.9224E-009,
     &                       -5.6840E-002, 3.2182E-008, 1.2884E-002,
     &                        6.6859E-009, 4.2958E-002, 7.5059E-009,
     &                        5.0972E-003,-3.4220E-002, 4.4177E-009,
     &                        6.6776E-003,-4.7692E-003, 1.1823E-008,
     &                       -8.8228E-003,-2.5359E-009,-1.1986E-002,
     &                       -5.1509E-003/
C     1500km June solstice
      DATA (DHEH(3,2,J),J=1,49)/-1.5728E+000,-6.8726E-001,-4.6811E-001,
     &                        2.4677E-002,-4.5196E-001, 1.5523E-001,
     &                        3.0631E-001, 1.4197E-001,-7.8123E-002,
     &                       -1.7428E-002,-1.7897E-002,-1.8015E-002,
     &                        2.7210E-002, 6.0701E-002,-1.3212E-001,
     &                       -2.2745E-002,-1.7608E-002,-1.2909E-002,
     &                        2.0402E-002,-4.0894E-003, 3.9555E-003,
     &                       -3.6464E-003, 1.4643E-002,-5.5944E-003,
     &                       -8.8090E-002,-1.0930E-002,-7.3501E-003,
     &                       -5.6046E-003, 2.6169E-003,-1.6782E-002,
     &                        1.4274E-002,-2.7868E-004, 2.1147E-003,
     &                       -1.8199E-002, 8.8925E-003,-1.5835E-003,
     &                        1.8784E-003, 1.1248E-002, 7.2779E-003,
     &                        4.4115E-004, 1.8361E-003,-1.1211E-003,
     &                        1.1060E-003, 1.1001E-002, 1.2477E-003,
     &                        9.0196E-003,-5.8886E-004, 9.7300E-003,
     &                        4.9376E-003/
C     2250km equinox
      DATA (DHEH(4,1,J),J=1,49)/-1.1230E+000,-2.9419E-007,-9.5822E-001,
     &                       -3.4817E-007,-3.5165E-001, 2.2927E-007,
     &                        3.3646E-001, 8.9248E-002,-1.1195E-007,
     &                        3.8351E-002,-7.4946E-008, 2.5411E-005,
     &                        2.1650E-008,-8.8392E-003,-1.7418E-008,
     &                        1.2222E-002, 4.5854E-009,-2.1108E-002,
     &                        3.0780E-008, 3.1391E-002,-9.2939E-009,
     &                        1.1868E-002,-2.3493E-009, 4.0791E-003,
     &                       -9.2411E-003,-3.1598E-009,-2.5908E-003,
     &                       -9.0595E-009,-1.0797E-003, 4.0200E-002,
     &                       -2.9380E-009,-1.5619E-003,-2.7627E-010,
     &                        2.2044E-002,-1.6962E-008,-8.5223E-003,
     &                       -3.6076E-009, 2.3448E-002,-4.9645E-009,
     &                       -5.8718E-004,-1.5134E-002,-8.6918E-009,
     &                       -2.3766E-003, 7.2023E-004, 9.0865E-010,
     &                        3.0388E-003,-2.6828E-009, 4.6501E-004,
     &                       -7.7390E-004/
C     2250km June solstice
      DATA (DHEH(4,2,J),J=1,49)/-1.3029E+000,-4.3965E-001,-4.3540E-001,
     &                       -1.2774E-001,-5.4683E-001, 8.9815E-002,
     &                        2.4691E-001, 1.5207E-001, 4.5816E-002,
     &                        4.2447E-002,-2.7108E-002, 2.7242E-003,
     &                       -7.3419E-003,-4.7334E-002, 5.0151E-002,
     &                       -2.1149E-002,-2.3378E-002, 4.3055E-003,
     &                       -1.6985E-002, 1.5813E-002,-1.6609E-002,
     &                        1.1566E-002, 6.2104E-003, 5.0605E-003,
     &                       -3.5118E-002,-2.0272E-002,-8.5016E-003,
     &                       -9.0160E-003,-6.8417E-003,-2.5045E-002,
     &                       -1.0184E-002,-6.3754E-003, 6.0554E-003,
     &                       -2.0355E-002,-2.8685E-003,-2.6734E-003,
     &                       -1.5766E-003, 6.4888E-003,-1.6234E-003,
     &                       -2.5859E-003, 6.6457E-003,-1.4526E-003,
     &                       -1.1457E-003, 2.2648E-003,-8.7925E-004,
     &                        4.1493E-003,-2.3712E-004, 7.9344E-004,
     &                        1.8450E-003/
C//////////////////////////////////////////////////////////////////////
C///////////////////////////////////N+/////////////////////////////////
C     550km equinox
      DATA (DNH(1,1,J),J=1,49)/-1.6313E+000, 3.3826E-009, 2.3816E-001,
     &                        2.8373E-007,-2.0961E-002,-5.3533E-007,
     &                        8.7160E-002, 9.8248E-002, 4.4888E-008,
     &                       -3.2244E-002,-2.0063E-008,-2.0732E-002,
     &                        1.4134E-009, 6.8670E-002, 3.8855E-008,
     &                       -7.9258E-002, 3.6878E-008, 3.0244E-002,
     &                       -3.3364E-008,-6.6861E-002, 3.2622E-008,
     &                        2.0265E-002,-1.4791E-008, 6.6954E-003,
     &                        2.1340E-002,-3.2037E-008, 9.0073E-003,
     &                        2.0858E-008,-5.2152E-003, 3.9714E-002,
     &                       -1.9344E-009,-8.9600E-005,-3.7487E-009,
     &                       -4.0648E-002, 1.7220E-008, 5.6330E-003,
     &                        4.4101E-009, 4.1397E-003,-4.3699E-010,
     &                       -3.5601E-003,-1.6551E-002,-2.6274E-009,
     &                        8.3802E-004, 1.2105E-003,-1.0517E-008,
     &                       -8.5131E-003, 4.5467E-009,-2.2753E-003,
     &                       -3.3013E-003/
C     550km June solstice
      DATA (DNH(1,2,J),J=1,49)/-1.5950E+000, 1.2602E-001, 2.4136E-001,
     &                        1.6546E-001, 1.7991E-002,-1.3398E-002,
     &                        9.3804E-002,-7.7106E-003, 1.4206E-002,
     &                       -2.3237E-003,-1.2863E-003, 2.3217E-004,
     &                       -2.2888E-003,-3.3507E-002, 2.1777E-002,
     &                       -2.3190E-002,-2.6550E-002, 5.4864E-003,
     &                        6.3951E-003,-4.8363E-002, 2.1732E-002,
     &                       -2.9250E-003,-7.9064E-003,-5.4980E-003,
     &                        4.0796E-002, 1.3459E-002, 7.4514E-003,
     &                       -5.7685E-003, 2.1205E-004,-1.9001E-002,
     &                       -1.4431E-003, 6.2449E-004,-1.2225E-003,
     &                        4.9048E-003,-1.4864E-002,-1.6067E-003,
     &                       -1.5020E-003,-3.7769E-003,-1.3646E-003,
     &                       -1.4496E-003,-1.2677E-002,-2.8348E-003,
     &                       -3.0407E-005,-3.0275E-003,-1.4841E-003,
     &                       -6.7625E-003,-2.2857E-003,-1.9180E-003,
     &                       -5.1806E-003/
C     900km equinox
      DATA (DNH(2,1,J),J=1,49)/-1.4724E+000, 6.2234E-007, 1.9984E-001,
     &                       -6.2436E-007,-5.9609E-002, 5.3063E-008,
     &                        4.0544E-002,-2.9918E-002, 4.1071E-007,
     &                        5.6303E-004,-4.7255E-008, 8.0654E-003,
     &                       -3.4962E-008, 1.6174E-002, 1.0136E-007,
     &                        1.1632E-002,-2.4108E-008, 1.0895E-002,
     &                       -1.4658E-008,-4.3236E-002, 1.5584E-007,
     &                       -7.6984E-003, 1.8395E-008, 6.3333E-004,
     &                       -5.2038E-003, 1.5845E-007,-6.8821E-003,
     &                       -1.8127E-008, 1.2382E-003,-6.6883E-002,
     &                        6.0510E-008,-7.3364E-003, 1.1055E-008,
     &                       -2.0130E-002, 1.0636E-007,-4.3419E-003,
     &                       -5.6930E-009,-1.9632E-002, 2.3733E-008,
     &                       -1.7396E-003, 4.7721E-003, 5.6015E-008,
     &                       -1.6795E-003,-4.7359E-004,-1.4109E-008,
     &                        1.4272E-004, 2.0978E-008,-2.9585E-003,
     &                        1.0551E-002/
C     900km June solstice
      DATA (DNH(2,2,J),J=1,49)/-1.4816E+000, 2.5836E-001, 2.5713E-001,
     &                       -1.1671E-002,-1.1685E-001,-8.0473E-002,
     &                       -2.5842E-002, 1.7538E-002, 3.1480E-002,
     &                       -5.2361E-003,-2.0114E-002, 1.0788E-002,
     &                        6.0475E-003,-8.2585E-002, 1.5506E-002,
     &                       -9.3973E-003, 6.9887E-003, 1.6035E-003,
     &                       -4.6125E-003, 1.2645E-003, 2.8444E-002,
     &                        8.2369E-003,-2.6763E-003,-7.5445E-004,
     &                        2.6349E-002,-1.6736E-002, 1.3463E-003,
     &                        1.7333E-005,-9.0561E-004,-8.1050E-003,
     &                       -5.6762E-003, 3.1943E-003,-3.0766E-004,
     &                       -2.6193E-002,-1.2177E-002,-1.2289E-003,
     &                        4.1217E-004,-2.4327E-002,-6.1348E-003,
     &                       -1.2113E-003,-1.7103E-002,-2.2901E-003,
     &                        6.3735E-004,-1.2284E-002,-3.8308E-003,
     &                       -1.0159E-002,-1.7879E-003,-1.2510E-002,
     &                       -1.0009E-002/
C     1500km equinox
      DATA (DNH(3,1,J),J=1,49)/-1.6315E+000, 1.1175E-007, 4.7753E-001,
     &                       -1.0014E-007,-1.0097E-001,-1.0216E-007,
     &                       -5.3935E-002,-3.3570E-001, 2.0709E-007,
     &                        4.4824E-002, 1.8159E-008, 2.2117E-002,
     &                       -8.4695E-008,-1.6189E-001, 9.9261E-008,
     &                        5.7796E-002, 4.8814E-008,-7.5845E-003,
     &                       -5.1309E-008,-1.2423E-001, 1.3321E-007,
     &                       -1.6181E-002,-7.7736E-009, 4.6002E-003,
     &                       -1.2281E-001, 2.4201E-007, 1.4288E-002,
     &                        1.1896E-008,-5.3069E-003,-1.8104E-002,
     &                       -1.9814E-008,-8.4131E-003, 2.2753E-009,
     &                        5.1336E-003, 1.4694E-007, 4.9619E-003,
     &                        4.1959E-009,-2.2226E-002,-5.4731E-008,
     &                       -5.2711E-003, 1.3040E-002, 4.8906E-008,
     &                        2.2301E-003,-2.7938E-004,-2.2648E-008,
     &                       -1.5969E-002,-6.5911E-009, 3.6104E-003,
     &                        2.9534E-003/
C     1500km June solstice
      DATA (DNH(3,2,J),J=1,49)/-1.5647E+000, 4.2744E-001, 4.7853E-001,
     &                       -2.7160E-001,-3.7019E-002, 2.1446E-002,
     &                       -1.3457E-001,-1.1104E-001, 8.7769E-002,
     &                        4.0593E-003,-2.7075E-002, 8.4188E-003,
     &                       -1.2262E-002,-6.4727E-002, 7.1687E-002,
     &                       -3.8468E-002,-7.9663E-003, 1.2872E-002,
     &                        2.8088E-003,-1.2956E-002,-3.9502E-002,
     &                       -7.9875E-005, 6.1428E-003,-1.2074E-003,
     &                        3.8344E-003, 3.3477E-003,-3.3677E-003,
     &                       -3.0964E-003, 9.6501E-004, 8.2409E-003,
     &                       -2.8989E-002, 4.3657E-003, 9.4355E-005,
     &                        1.3130E-002,-1.8814E-002, 2.7093E-003,
     &                       -1.2167E-003,-5.7969E-003,-6.4927E-003,
     &                        4.1950E-004,-9.1788E-003,-7.2444E-003,
     &                       -1.4730E-003,-1.0845E-002,-2.5005E-003,
     &                       -8.2969E-003,-1.9660E-003,-6.3399E-003,
     &                       -5.8925E-003/
C     2250km equinox
      DATA (DNH(4,1,J),J=1,49)/-1.7525E+000,-1.0714E-006, 8.6183E-001,
     &                        1.1184E-006,-2.7829E-001, 2.7162E-007,
     &                       -1.0538E-001,-1.3943E-001,-1.1095E-007,
     &                        4.5835E-002,-1.8177E-007, 8.3712E-003,
     &                        1.0937E-007,-4.2987E-001,-3.9255E-007,
     &                        6.6012E-002, 5.4483E-008, 9.0376E-003,
     &                        7.3468E-008, 5.0653E-003,-6.8615E-009,
     &                       -1.3051E-002,-4.6976E-009, 3.9132E-003,
     &                       -3.8456E-002, 1.6913E-008,-8.3270E-004,
     &                       -3.9315E-008, 2.9990E-003,-5.9986E-003,
     &                        6.4241E-009,-3.6095E-004,-4.3472E-009,
     &                        9.3971E-002, 6.1373E-008,-7.0760E-003,
     &                       -2.7203E-009, 4.5148E-002,-1.1452E-008,
     &                       -1.6323E-004, 2.2101E-002, 5.6630E-009,
     &                       -9.0528E-004, 6.7390E-003, 1.1191E-009,
     &                        5.7927E-003, 2.2189E-009, 8.9446E-003,
     &                       -6.3752E-004/
C     2250km June solstice
      DATA (DNH(4,2,J),J=1,49)/-1.7520E+000, 3.8232E-001, 8.1527E-001,
     &                       -2.8870E-001,-1.0730E-001, 7.0220E-002,
     &                       -1.6764E-001,-2.1758E-001,-2.0171E-002,
     &                        3.4368E-002,-2.2874E-003, 2.7205E-002,
     &                       -6.4735E-003,-3.3147E-001, 9.2558E-002,
     &                        4.9336E-002,-4.1876E-002, 5.0738E-003,
     &                        1.2235E-002,-1.2631E-002,-2.6016E-002,
     &                        1.0295E-002,-6.0847E-003, 2.2948E-003,
     &                       -1.8060E-001,-1.7793E-002, 5.4176E-003,
     &                        2.2462E-004, 1.8786E-003, 1.1605E-001,
     &                        1.7233E-003,-1.5451E-003, 1.3382E-003,
     &                       -7.3353E-002,-3.7852E-004, 1.3236E-003,
     &                       -9.6993E-004, 1.8479E-002,-5.6199E-003,
     &                        8.0329E-004,-1.7815E-002, 3.5429E-003,
     &                       -1.5325E-003,-4.6303E-003,-3.9437E-003,
     &                       -1.7196E-002,-2.0703E-003,-3.6631E-004,
     &                       -1.6702E-002/
C//////////////////////////////////////////////////////////////////////
C/////////////////coefficients low solar activity///////////////////// 
C//////////////////////////////////O+//////////////////////////////////
C     400km equinox
      DATA (DOL(1,1,J),J=1,49)/-3.4295E-003, 4.8322E-010, 7.9335E-004,
     &                        1.8237E-009, 1.0320E-003,-7.3733E-010,
     &                       -5.8045E-004,-2.1541E-003,-6.5013E-010,
     &                       -3.1081E-004,-9.8478E-012, 8.0628E-005,
     &                        2.1821E-010,-1.9044E-003,-8.3791E-010,
     &                       -1.5618E-004,-4.6595E-011, 1.5868E-004,
     &                       -1.6618E-010, 7.2724E-005,-3.1159E-010,
     &                        1.5783E-004,-6.1281E-010,-3.2544E-005,
     &                       -5.8917E-004,-6.1467E-010,-1.0295E-004,
     &                        5.7992E-011, 5.7641E-005, 6.7711E-005,
     &                        6.1432E-010, 8.6370E-005,-2.3670E-010,
     &                        2.2941E-005,-4.7808E-011, 4.7716E-005,
     &                        2.1198E-011, 2.8298E-006, 3.6265E-010,
     &                       -4.4578E-006, 1.7541E-004, 2.1511E-010,
     &                        2.5195E-005,-2.7325E-005,-2.3875E-011,
     &                       -3.1418E-006, 4.6152E-011,-2.9151E-005,
     &                        3.7913E-005/
C     400km June solstice
      DATA (DOL(1,2,J),J=1,49)/-7.5061E-003, 4.2214E-003, 3.2811E-003,
     &                       -4.3773E-003, 4.1127E-005, 2.7276E-003,
     &                       -4.5069E-004,-6.9573E-003, 3.2289E-003,
     &                        4.5324E-004,-5.4022E-004,-2.8733E-004,
     &                        1.7425E-004,-4.4235E-003,-1.1619E-005,
     &                        1.3238E-003,-5.1465E-004,-3.3052E-004,
     &                        3.8804E-004, 6.8531E-004,-1.9665E-004,
     &                        1.9622E-004, 2.8863E-004,-6.5642E-005,
     &                       -2.8855E-003, 5.0512E-004, 7.0149E-004,
     &                       -1.5869E-004,-1.5202E-004, 1.5939E-003,
     &                       -5.6796E-004,-1.0670E-004, 1.2569E-007,
     &                       -8.3699E-004,-8.4185E-005, 2.4768E-005,
     &                        4.6445E-005, 1.9761E-004, 6.0184E-005,
     &                       -1.0454E-005, 3.2389E-004,-3.7438E-005,
     &                       -3.4186E-005,-3.5859E-004,-6.1472E-005,
     &                       -4.7218E-004, 7.6277E-006, 1.4752E-004,
     &                       -4.5090E-004/
C     650km equinox
      DATA (DOL(2,1,J),J=1,49)/-2.6245E-001, 8.4041E-007, 2.2991E-001,
     &                       -2.1060E-006,-5.9700E-002, 5.5301E-006,
     &                        2.6165E-002,-3.4817E-001, 2.5875E-007,
     &                        1.7171E-002,-7.7857E-007,-6.4432E-003,
     &                        6.9845E-007,-1.3705E-001, 1.0700E-006,
     &                        7.5614E-003,-5.6468E-007, 8.2754E-004,
     &                        1.9031E-007,-2.5396E-002,-7.2603E-007,
     &                       -1.7557E-002, 2.1324E-007,-1.0498E-003,
     &                       -6.4057E-002, 4.6894E-007,-9.1390E-003,
     &                        9.6493E-009, 1.7969E-004, 7.0926E-002,
     &                       -3.6416E-007,-6.9695E-003, 8.9469E-008,
     &                        2.4310E-002,-1.7204E-007,-5.4500E-003,
     &                        9.1857E-008, 2.1846E-002, 8.1249E-008,
     &                       -7.2438E-004, 2.1225E-002,-1.1084E-008,
     &                       -4.9135E-004,-1.5282E-003, 5.4962E-008,
     &                       -2.0812E-003, 3.7817E-008,-4.2919E-004,
     &                        1.7766E-004/
C     650km June solstice
      DATA (DOL(2,2,J),J=1,49)/-3.1262E-001, 2.1640E-001, 2.9808E-001,
     &                       -2.9615E-001, 6.4926E-002, 3.8438E-003,
     &                       -9.0777E-002,-3.8422E-001, 1.3193E-001,
     &                        3.1168E-002,-3.6264E-002, 2.3774E-002,
     &                       -9.3167E-003,-1.5581E-001, 1.5604E-002,
     &                        2.3125E-002, 1.3240E-002,-1.2961E-003,
     &                       -1.1848E-002,-3.2185E-002,-5.1446E-003,
     &                        1.0193E-002,-7.9351E-003, 3.2452E-003,
     &                       -1.3403E-001,-1.0768E-003, 1.2773E-002,
     &                        2.9588E-003,-9.6663E-004, 5.6863E-002,
     &                       -2.1862E-002, 1.0585E-002,-3.1121E-003,
     &                       -3.3781E-002,-1.2186E-002, 4.7556E-003,
     &                       -5.7030E-004, 1.2328E-002,-6.4108E-003,
     &                        1.7929E-003,-2.1691E-003,-8.2313E-003,
     &                        1.9333E-003,-1.1646E-002,-1.6945E-003,
     &                       -2.7066E-002, 1.3570E-004,-8.5273E-003,
     &                       -1.5711E-002/
C     1000km equinox
      DATA (DOL(3,1,J),J=1,49)/-8.9352E-001, 2.4097E-005, 3.7286E-001,
     &                       -1.0359E-005, 1.0068E-002,-1.7035E-005,
     &                       -2.0139E-002,-1.0039E+000, 8.8331E-006,
     &                       -1.3731E-001, 4.7035E-006,-3.6637E-002,
     &                       -2.6654E-006,-2.0386E-001, 1.5439E-005,
     &                       -3.6661E-002, 1.0260E-005,-4.5066E-002,
     &                       -2.8682E-006,-1.7254E-001,-4.9526E-006,
     &                       -6.7622E-002,-1.0877E-006,-1.2351E-002,
     &                       -1.0953E-001, 7.0854E-006,-1.4296E-002,
     &                        6.7187E-006,-2.0577E-002, 6.4692E-002,
     &                       -3.0932E-006,-1.1908E-002,-1.6660E-006,
     &                        6.6329E-002,-7.0914E-007,-1.5392E-002,
     &                        2.1883E-006, 4.5838E-003,-8.4412E-007,
     &                        5.4739E-004, 2.8565E-002,-9.7635E-007,
     &                        5.0974E-003,-5.1648E-004,-2.9444E-008,
     &                       -1.0738E-003,-2.7121E-007, 3.4379E-003,
     &                       -2.1828E-003/
C     1000km June solstice
      DATA (DOL(3,2,J),J=1,49)/-6.9317E-001, 3.3146E-001, 5.9247E-001,
     &                       -3.8841E-001, 1.5031E-001, 3.4648E-002,
     &                       -2.0436E-001,-7.6788E-001, 1.1303E-001,
     &                       -3.0861E-002, 3.1730E-002, 5.8057E-002,
     &                       -3.2321E-002,-2.3509E-001, 1.2907E-001,
     &                       -2.5901E-002, 9.7355E-003, 3.0717E-002,
     &                       -2.7170E-002,-1.0447E-001,-7.0094E-002,
     &                       -2.6774E-002, 2.0725E-002, 2.4860E-004,
     &                       -2.9119E-001, 9.3440E-002,-8.0132E-003,
     &                       -1.9018E-003, 4.4841E-003, 5.9359E-002,
     &                       -1.9317E-002,-1.8184E-002, 5.0489E-003,
     &                       -1.0292E-001, 1.2137E-002, 8.1073E-004,
     &                        7.1284E-004, 8.3372E-003, 1.3340E-002,
     &                       -6.7512E-003, 1.7102E-002,-2.4549E-003,
     &                       -1.7239E-003, 1.9465E-002,-5.4019E-003,
     &                        4.8407E-002,-4.4151E-003,-1.9067E-002,
     &                        1.5001E-002/
C//////////////////////////////////////////////////////////////////////
C//////////////////////////////////H+//////////////////////////////////
C     400km equinox
      DATA (DHL(1,1,J),J=1,49)/-2.3735E+000,-4.1106E-007,-1.5043E-001,
     &                        7.1050E-008,-4.4023E-002, 5.1900E-008,
     &                        7.5167E-002, 2.6079E-001,-5.4677E-008,
     &                        4.0421E-002, 8.4393E-009, 4.2554E-003,
     &                        1.7166E-008, 1.9018E-001,-6.0764E-008,
     &                        3.8687E-002, 6.3717E-008, 6.4895E-003,
     &                       -4.0891E-008, 3.8167E-002, 1.8652E-008,
     &                       -1.0038E-002, 1.9645E-008, 2.1804E-003,
     &                       -1.4444E-002, 6.5822E-009, 7.0666E-003,
     &                       -8.4659E-009,-5.5334E-003, 1.5556E-002,
     &                        1.2414E-008,-4.3661E-003, 4.4984E-009,
     &                        9.3627E-003,-2.4554E-009,-3.6096E-003,
     &                        7.8989E-009,-1.2352E-002, 1.0504E-008,
     &                       -4.5357E-006, 7.8762E-004,-5.2915E-009,
     &                       -1.9697E-003, 4.2966E-004, 5.9770E-009,
     &                        3.7248E-003, 6.9259E-009, 3.0955E-003,
     &                        2.7742E-003/
C     400km June solstice
      DATA (DHL(1,2,J),J=1,49)/-2.2303E+000,-2.7930E-001,-1.6289E-001,
     &                        8.4439E-002, 4.3059E-002,-1.0900E-002,
     &                        5.9060E-003, 3.8539E-001,-9.7745E-002,
     &                        1.8579E-002, 1.4256E-002, 6.8489E-004,
     &                       -1.1027E-003, 2.3516E-001, 3.8591E-002,
     &                       -2.9264E-002,-1.9275E-003, 2.4632E-002,
     &                       -3.0091E-004,-2.4136E-002, 2.1471E-002,
     &                       -1.4274E-002,-2.9073E-003, 4.0650E-003,
     &                        2.6483E-002, 3.9806E-003,-1.3560E-002,
     &                        3.6952E-004, 5.3108E-004,-3.9132E-002,
     &                        2.3689E-002,-6.6253E-004, 1.3556E-003,
     &                        2.3462E-002,-3.2744E-003, 1.4565E-003,
     &                        2.4812E-004,-3.2051E-004, 2.6108E-003,
     &                        7.5391E-004,-1.9602E-002, 5.0088E-003,
     &                        8.0312E-004, 1.3604E-002, 3.2853E-003,
     &                        8.1745E-003, 1.9033E-003, 1.6966E-002,
     &                        1.2348E-002/
C     650km equinox
      DATA (DHL(2,1,J),J=1,49)/-7.5599E-001,-2.3535E-007,-4.1761E-001,
     &                       -2.8901E-008, 4.8799E-002,-1.4005E-007,
     &                       -7.5257E-002, 5.0850E-001,-5.5769E-008,
     &                        7.4268E-002,-4.0953E-008, 2.0880E-002,
     &                       -3.9792E-008, 1.9637E-001, 3.5212E-008,
     &                        3.5924E-002,-3.2961E-008,-1.1911E-002,
     &                        5.4324E-009, 2.9918E-002, 1.0830E-008,
     &                        3.4518E-002,-5.4744E-009, 1.0144E-002,
     &                       -1.5615E-002, 9.3932E-009, 7.9662E-003,
     &                       -4.4936E-009,-1.4126E-003,-3.1648E-002,
     &                        2.2804E-008, 6.2742E-003,-9.5574E-009,
     &                       -1.1306E-002, 1.6269E-009, 2.2078E-004,
     &                        2.8647E-009,-1.7932E-002,-5.0077E-009,
     &                       -2.3559E-003,-9.2953E-003,-5.1441E-009,
     &                       -2.2185E-003, 2.9117E-005,-4.8547E-009,
     &                        4.4236E-003,-2.8102E-009, 9.3261E-004,
     &                        1.9538E-003/
C     650km June solstice
      DATA (DHL(2,2,J),J=1,49)/-7.6906E-001,-4.2549E-001,-6.2598E-001,
     &                        2.2279E-001, 1.4493E-001, 1.0653E-001,
     &                        2.7012E-001, 3.8710E-001,-6.1640E-002,
     &                        4.6697E-002,-5.7444E-002, 2.0933E-002,
     &                        8.8119E-003, 1.4986E-001, 2.1907E-002,
     &                       -1.8032E-002,-4.6878E-002,-1.6714E-002,
     &                        4.2935E-002,-2.4183E-002, 2.0290E-002,
     &                       -1.0109E-002, 5.2285E-003,-6.9878E-003,
     &                        4.2781E-002, 5.6690E-003,-1.1873E-002,
     &                       -4.5405E-003,-3.6632E-003,-2.2072E-002,
     &                        1.2209E-003,-5.8301E-003, 3.1915E-006,
     &                        1.0209E-002, 1.9771E-003, 1.3042E-003,
     &                        1.4817E-003, 2.0904E-003,-7.5031E-004,
     &                        2.2646E-003, 1.1547E-002, 6.7321E-003,
     &                        9.5170E-004, 1.7845E-002, 6.1338E-003,
     &                        1.2967E-002, 2.3311E-003, 2.9597E-002,
     &                       -2.2654E-003/
C     1000km equinox
      DATA (DHL(3,1,J),J=1,49)/-3.1869E-001, 1.5090E-007,-4.0560E-001,
     &                        2.8552E-007,-4.2289E-003, 3.6878E-008,
     &                        1.9957E-001, 2.7526E-001, 4.0798E-007,
     &                        1.1343E-001,-1.0028E-007, 5.1526E-002,
     &                       -6.0643E-008, 9.2397E-002,-2.1866E-007,
     &                        8.6528E-002, 2.3460E-008, 3.6848E-002,
     &                        6.2456E-008, 1.5483E-002,-1.7108E-007,
     &                        3.6333E-002,-1.0845E-008, 1.0259E-002,
     &                        4.3320E-003,-2.6987E-007,-1.0254E-002,
     &                       -8.8644E-008,-2.1170E-003,-2.1956E-002,
     &                       -1.3044E-007,-6.8424E-003,-3.8852E-008,
     &                       -1.6083E-002,-2.8545E-008, 4.7800E-003,
     &                        4.3092E-008,-9.4451E-004,-4.6383E-008,
     &                        1.7086E-003, 7.9651E-003, 2.1903E-007,
     &                        3.3880E-004, 4.5247E-004, 1.0538E-007,
     &                        3.7229E-003,-8.6806E-008,-5.2132E-004,
     &                       -5.7966E-004/
C     1000km June solstice
      DATA (DHL(3,2,J),J=1,49)/-4.6737E-001,-1.2403E-001,-6.4613E-001,
     &                        1.8831E-001, 1.2419E-001,-5.9911E-002,
     &                        1.9218E-001, 2.9484E-001, 4.0311E-002,
     &                        9.8207E-002,-2.9219E-002,-1.1908E-002,
     &                        3.8705E-002,-1.8943E-003,-4.2874E-002,
     &                       -4.6060E-002,-3.4199E-002,-2.2322E-002,
     &                        2.5785E-002, 2.5357E-002, 2.7261E-002,
     &                        9.8865E-003, 1.6691E-003, 6.2808E-003,
     &                       -9.1296E-003,-1.3707E-002,-8.7014E-003,
     &                       -3.4345E-003,-4.6994E-003,-2.5409E-002,
     &                       -6.7929E-003, 1.2701E-003, 3.6829E-003,
     &                       -2.9346E-003,-2.1371E-003,-7.4109E-003,
     &                        1.4351E-003,-7.4944E-003,-2.3530E-003,
     &                       -2.3960E-003,-8.2307E-003,-4.0801E-004,
     &                        1.9430E-003, 1.8990E-003, 6.7012E-004,
     &                       -2.2565E-003,-4.5399E-004,-1.7694E-003,
     &                       -6.3397E-004/
C//////////////////////////////////////////////////////////////////////
C//////////////////////////////////He+/////////////////////////////////
C     400km equinox
      DATA (DHEL(1,1,J),J=1,49)/-2.8533E+000,-2.1986E-007, 7.2644E-002,
     &                        2.2489E-007,-1.8677E-001,-3.9095E-007,
     &                        1.0850E-002, 2.2428E-001,-1.5216E-008,
     &                       -1.0736E-001,-7.9766E-008,-4.1078E-002,
     &                        4.7277E-008, 6.3340E-001,-1.5529E-008,
     &                        8.1139E-003, 1.4044E-008, 5.8076E-003,
     &                       -4.6109E-008,-8.8933E-002,-6.0933E-009,
     &                        8.9345E-003, 7.8024E-009, 1.0524E-002,
     &                       -7.0800E-002, 3.0069E-008,-3.8559E-002,
     &                        1.9810E-009,-2.7640E-002,-3.8927E-002,
     &                        2.5396E-008,-5.9943E-003, 1.4326E-008,
     &                       -2.0216E-002,-1.0963E-008,-1.0778E-002,
     &                       -3.1408E-009,-9.0961E-003,-1.6521E-008,
     &                        5.3029E-003,-3.3221E-002, 2.9052E-011,
     &                       -1.9158E-003, 6.3675E-003,-8.1957E-009,
     &                        7.4360E-003,-7.6241E-009, 6.5228E-003,
     &                        3.2586E-003/
C     400km June solstice
      DATA (DHEL(1,2,J),J=1,49)/-3.0612E+000,-1.0562E+000, 8.8532E-002,
     &                        8.5373E-002, 8.1474E-002, 2.8747E-002,
     &                        1.3534E-001, 4.3580E-001, 4.4317E-002,
     &                       -1.8054E-002,-1.3027E-002, 4.1295E-002,
     &                       -4.4592E-003, 1.0223E-001, 1.3085E-001,
     &                       -7.7696E-002,-7.3836E-002, 1.9780E-002,
     &                        1.5735E-002,-5.9522E-002, 4.8434E-002,
     &                        1.5970E-002, 3.5974E-003,-3.8010E-003,
     &                       -1.0031E-001, 1.7651E-002, 1.2491E-002,
     &                        9.0502E-003,-8.7768E-003,-9.6294E-003,
     &                        1.8994E-002, 4.6892E-003, 2.5748E-004,
     &                       -9.6002E-003,-6.2450E-003, 9.0447E-003,
     &                       -1.8477E-003, 1.8898E-002,-6.9182E-003,
     &                        2.0626E-003, 4.7967E-003,-5.7386E-003,
     &                       -6.0267E-004, 2.5325E-002, 1.1937E-003,
     &                        2.1619E-002,-1.3459E-003, 3.7915E-002,
     &                        1.7314E-002/
C     650km equinox
      DATA (DHEL(2,1,J),J=1,49)/-1.6103E+000,-1.3811E-007, 1.1838E-001,
     &                        2.4209E-007,-1.2965E-001,-6.5882E-008,
     &                        1.3191E-001, 4.6161E-001,-2.5600E-007,
     &                        1.2864E-001, 7.8717E-008, 2.9376E-002,
     &                       -2.0378E-009, 3.7085E-001, 2.5941E-007,
     &                        2.3336E-002,-2.5896E-007, 7.0754E-002,
     &                        1.5037E-007,-1.6104E-001, 2.5861E-008,
     &                        2.1873E-002,-3.9311E-010, 1.7883E-002,
     &                       -5.9487E-002, 7.5016E-008,-3.8658E-003,
     &                       -1.5184E-008,-2.2297E-002,-3.2125E-002,
     &                        1.3503E-008,-1.0069E-003, 2.3685E-008,
     &                       -2.3076E-002, 1.6395E-008,-4.7465E-003,
     &                        2.1465E-009,-2.1087E-002,-1.0412E-008,
     &                       -4.4450E-003, 6.9945E-003, 1.6080E-008,
     &                        3.1289E-003, 9.4760E-003,-8.4313E-009,
     &                       -2.1643E-003,-8.3007E-009, 2.3316E-003,
     &                       -8.8253E-003/
C     650km June solstice
      DATA (DHEL(2,2,J),J=1,49)/-2.2374E+000,-7.4507E-001,-1.4689E-001,
     &                       -2.5946E-002, 4.7283E-002, 1.4143E-001,
     &                        3.2299E-001, 1.9366E-001, 8.7688E-002,
     &                        1.2526E-002,-2.2810E-002,-2.2711E-003,
     &                       -1.1824E-002,-4.8523E-002,-8.2298E-004,
     &                       -2.2395E-001,-3.4992E-002, 1.8125E-002,
     &                        1.4230E-002,-2.7661E-002, 2.3424E-002,
     &                        4.7094E-003,-1.0739E-002,-3.4746E-003,
     &                       -2.2153E-001,-1.8756E-002,-7.1623E-003,
     &                        4.6047E-003,-4.5071E-003, 2.2894E-002,
     &                       -2.4285E-002,-5.5847E-003,-9.8852E-004,
     &                        6.7171E-002,-5.0134E-004,-2.9361E-003,
     &                       -4.2558E-003, 1.5103E-002,-9.7860E-003,
     &                       -1.8098E-003, 1.8795E-002, 4.5063E-003,
     &                        2.4747E-003, 1.1677E-002,-4.2526E-003,
     &                        1.4606E-002, 2.2638E-003, 2.1285E-002,
     &                        1.3963E-002/
C     1000km equinox
      DATA (DHEL(3,1,J),J=1,49)/-1.3192E+000, 1.8143E-006,-2.1284E-002,
     &                       -5.7860E-006,-1.3203E-001, 1.0367E-006,
     &                        8.7882E-002, 2.5246E-001, 3.0540E-007,
     &                        1.2671E-001, 7.0752E-007, 5.1175E-002,
     &                       -1.0432E-006, 1.5597E-001,-1.9061E-007,
     &                        9.7418E-002, 2.2626E-006, 6.3152E-002,
     &                       -2.4478E-006,-1.6992E-001,-6.0624E-007,
     &                       -1.6865E-002, 2.6681E-007, 2.4771E-003,
     &                       -3.9535E-002, 5.9015E-007,-5.4337E-002,
     &                       -1.4229E-007,-2.5864E-002, 4.5711E-002,
     &                        1.4937E-007,-1.9960E-002,-1.0504E-007,
     &                        1.2233E-002,-6.6122E-008, 8.5225E-004,
     &                        8.6051E-009, 2.7375E-002, 6.5450E-008,
     &                       -6.1311E-003, 1.2666E-002, 1.9864E-007,
     &                        2.8454E-003, 1.9020E-002,-5.1153E-008,
     &                        4.4576E-003,-2.0117E-008, 8.6293E-003,
     &                       -5.5447E-003/
C     1000km June solstice
      DATA (DHEL(3,2,J),J=1,49)/-1.9424E+000,-5.8403E-001, 3.4084E-001,
     &                       -1.9084E-001,-5.4692E-002, 2.0943E-001,
     &                        6.7653E-003, 1.7048E-001, 1.9560E-001,
     &                        7.2251E-002,-1.3912E-003, 4.9874E-002,
     &                       -5.1299E-003,-2.2192E-001,-1.3285E-001,
     &                       -1.7111E-001,-2.8852E-002, 1.7141E-002,
     &                       -4.1047E-002, 1.3092E-001, 2.9271E-002,
     &                        2.1492E-002, 3.1053E-002, 1.7248E-002,
     &                       -1.7665E-001,-1.9095E-003,-1.0090E-002,
     &                       -2.8027E-002,-1.5999E-002, 6.9373E-002,
     &                       -4.0136E-002, 1.3345E-002, 9.5536E-003,
     &                       -1.0609E-002,-2.2548E-002,-1.5098E-002,
     &                       -1.1711E-002, 2.6458E-002,-1.5922E-002,
     &                        3.4746E-003,-1.8009E-002, 4.8529E-004,
     &                       -3.8353E-003, 1.9446E-003,-7.4106E-003,
     &                       -3.9309E-003,-1.3632E-003,-4.7108E-003,
     &                        7.2728E-003/
C/////////////////////////////////////////////////////////////////////
C//////////////////////////////////N+/////////////////////////////////
C     400km equinox
      DATA (DNL(1,1,J),J=1,49)/-1.7368E+000,-3.0027E-008, 2.2184E-001,
     &                       -6.7089E-007,-1.0635E-001, 6.8139E-007,
     &                        5.8091E-002,-6.2121E-002, 3.1864E-007,
     &                        4.8208E-002,-2.7440E-007,-2.4000E-003,
     &                        6.6031E-008,-1.0868E-001, 7.2869E-008,
     &                       -1.0042E-002,-4.6008E-008, 1.6205E-003,
     &                        4.6331E-009,-3.6398E-002, 1.7139E-007,
     &                        6.2127E-004,-4.0138E-008, 1.2439E-003,
     &                       -1.8217E-002, 4.6073E-008, 3.7524E-003,
     &                       -2.0566E-008,-3.0241E-003, 2.7188E-002,
     &                        6.3375E-008,-3.7723E-003,-3.9013E-009,
     &                        6.9304E-003, 5.7030E-008,-1.2236E-004,
     &                       -6.4988E-009, 1.2409E-002, 6.2839E-009,
     &                       -1.4527E-003, 1.4370E-003, 1.8605E-008,
     &                        1.8677E-004, 3.9142E-003,-4.8721E-009,
     &                       -4.1931E-003, 7.9621E-009, 1.9265E-004,
     &                       -1.3332E-003/
C     400km June solstice
      DATA (DNL(1,2,J),J=1,49)/-1.7418E+000, 7.0525E-002, 2.9785E-001,
     &                        1.1675E-002,-9.2159E-002,-1.2950E-001,
     &                       -5.8461E-002,-1.3966E-001, 1.5042E-002,
     &                        4.6388E-002,-9.7774E-003, 3.5422E-003,
     &                       -8.6287E-003,-8.7710E-002, 3.8852E-002,
     &                       -9.0949E-003,-1.8152E-002, 3.6013E-004,
     &                        7.2089E-003, 2.5707E-002, 8.4327E-003,
     &                       -6.5605E-003, 4.8306E-004, 5.0042E-004,
     &                       -3.1783E-002, 5.7723E-003, 8.8230E-003,
     &                       -2.6260E-003,-1.1217E-003, 5.7169E-002,
     &                       -5.2793E-003,-3.1765E-003, 5.1564E-004,
     &                        1.3519E-002,-3.9896E-003, 1.7336E-003,
     &                       -2.8791E-004, 1.3395E-002,-5.3013E-003,
     &                       -5.6986E-004, 3.0630E-003,-3.8017E-003,
     &                        9.3966E-004,-5.1651E-004,-3.0807E-003,
     &                       -4.4359E-003,-2.0503E-003, 8.0675E-004,
     &                        1.1912E-004/
C     650km equinox
      DATA (DNL(2,1,J),J=1,49)/-1.5547E+000, 6.7091E-007, 4.0622E-001,
     &                       -5.5830E-008,-1.3901E-001,-6.7244E-007,
     &                        1.4880E-001,-8.2658E-002, 2.6659E-007,
     &                        1.0021E-002, 1.3823E-007,-7.4716E-003,
     &                       -8.9220E-008,-1.3959E-001, 2.0864E-007,
     &                       -1.0484E-002, 4.4276E-008, 1.9706E-002,
     &                       -1.1884E-007,-1.2037E-002,-6.2490E-008,
     &                       -2.9276E-002, 4.0271E-008,-1.2310E-002,
     &                       -2.6679E-003, 3.5891E-008,-6.5922E-003,
     &                       -1.6467E-008,-3.9885E-004, 2.0962E-002,
     &                       -5.5785E-008,-7.4266E-003, 2.5071E-008,
     &                        2.2400E-002,-2.8034E-008,-1.2509E-003,
     &                       -1.9655E-008, 1.0287E-002, 2.6129E-008,
     &                       -1.3332E-003, 1.0731E-002, 2.4252E-009,
     &                        1.5417E-003, 3.1698E-003, 1.8012E-008,
     &                       -3.1057E-003, 1.5340E-008, 3.0302E-003,
     &                       -2.9436E-003/
C     650km June solstice
      DATA (DNL(2,2,J),J=1,49)/-1.5723E+000, 4.0251E-001, 4.0235E-001,
     &                       -1.6855E-001,-1.4445E-001,-2.9990E-002,
     &                       -2.0387E-001,-1.7979E-001, 1.9726E-001,
     &                       -6.8767E-002,-2.7798E-002, 4.5989E-003,
     &                        1.3561E-002,-1.2212E-001, 2.4244E-002,
     &                       -4.2670E-002, 6.2073E-002,-5.2021E-003,
     &                       -2.3860E-002,-6.4837E-002, 3.1524E-002,
     &                       -1.8784E-002, 1.2402E-002, 1.1119E-005,
     &                       -1.9303E-002,-2.2166E-002, 1.1413E-002,
     &                       -2.2769E-003, 1.0334E-003,-3.6042E-003,
     &                       -3.4116E-003,-4.2969E-003, 3.7668E-003,
     &                       -1.6617E-002,-2.0903E-002, 1.1176E-002,
     &                       -3.4928E-003,-1.9803E-002,-3.7789E-003,
     &                        2.9788E-004,-3.1880E-002,-1.0222E-002,
     &                        3.7033E-003,-3.0094E-002,-2.2242E-004,
     &                       -2.8816E-002,-4.4691E-003,-2.2928E-002,
     &                       -1.6669E-002/
C     1000km equinox
      DATA (DNL(3,1,J),J=1,49)/-1.7382E+000,-6.0635E-007, 4.4740E-001,
     &                        4.7518E-007, 9.1015E-002, 8.6631E-007,
     &                       -4.1582E-003,-3.1542E-001,-8.6896E-007,
     &                       -8.8282E-002, 1.7889E-007,-3.8424E-002,
     &                        5.6129E-008,-1.0561E-001, 1.0863E-007,
     &                       -3.7752E-002,-1.1781E-007,-4.1151E-002,
     &                       -1.4323E-008,-3.8984E-002,-4.7271E-007,
     &                       -3.7386E-002, 8.5416E-008,-1.2316E-002,
     &                        1.0742E-001, 1.5944E-007,-2.8192E-003,
     &                       -1.2504E-008,-1.6905E-002, 2.8270E-002,
     &                       -1.9685E-007, 8.9762E-003, 2.8706E-008,
     &                        6.7218E-002, 5.7165E-008,-8.2717E-003,
     &                        3.0388E-008, 1.9133E-002, 1.4687E-008,
     &                        5.5305E-004, 7.9431E-003, 4.8793E-008,
     &                        8.6786E-003, 4.9010E-003, 3.2400E-008,
     &                       -3.8863E-003,-2.5953E-008,-2.3986E-003,
     &                       -6.9512E-003/
C     1000km June solstice
      DATA (DNL(3,2,J),J=1,49)/-1.4667E+000, 1.6300E-001, 6.4765E-001,
     &                       -1.6832E-001,-1.9603E-001, 1.3735E-001,
     &                       -2.8157E-001,-9.1417E-002,-2.4826E-002,
     &                       -2.7273E-002, 3.1754E-002, 2.0120E-002,
     &                       -6.8389E-003,-9.6535E-002, 1.9137E-002,
     &                       -3.2374E-002, 7.1156E-002, 1.3993E-002,
     &                       -3.8484E-002, 3.1979E-002,-4.2560E-002,
     &                       -3.8190E-003, 1.1174E-002,-2.3599E-003,
     &                        3.4835E-003,-6.4330E-003,-1.4724E-003,
     &                       -2.7194E-003, 1.8374E-003, 7.9017E-003,
     &                       -1.3993E-002, 1.4415E-004, 1.8409E-003,
     &                        1.5734E-003,-1.3150E-002,-4.3392E-003,
     &                       -8.7189E-004,-6.9494E-003,-7.0281E-003,
     &                       -1.5472E-003, 7.6997E-004,-9.7752E-003,
     &                       -1.0346E-003,-4.2392E-003,-7.3591E-003,
     &                        1.0610E-002,-5.8767E-003, 2.4544E-004,
     &                        6.0162E-003/
C//////////////////////////////////////////////////////////////////////
C/////////////////////////solar minimum////////////////////////////////
      CALL IONLOW(CRD,INVDIP,FL,DIMO,B0,DIPL,MLT,ALT,DDD,DOL,0,NOL)
      CALL IONLOW(CRD,INVDIP,FL,DIMO,B0,DIPL,MLT,ALT,DDD,DHL,1,NHL)
      CALL IONLOW(CRD,INVDIP,FL,DIMO,B0,DIPL,MLT,ALT,DDD,DHEL,2,NHEL)
      CALL IONLOW(CRD,INVDIP,FL,DIMO,B0,DIPL,MLT,ALT,DDD,DNL,3,NNL)
C     normalization
      NTOT=NOL+NHL+NHEL+NNL
      NOL=NOL/NTOT
      NHL=NHL/NTOT
      NHEL=NHEL/NTOT
      NNL=NNL/NTOT
C///////////////////////////solar maximum//////////////////////////////
      CALL IONHIGH(CRD,INVDIP,FL,DIMO,B0,DIPL,MLT,ALT,DDD,DOH,0,NOH)
      CALL IONHIGH(CRD,INVDIP,FL,DIMO,B0,DIPL,MLT,ALT,DDD,DHH,1,NHH)
      CALL IONHIGH(CRD,INVDIP,FL,DIMO,B0,DIPL,MLT,ALT,DDD,DHEH,2,NHEH)
      CALL IONHIGH(CRD,INVDIP,FL,DIMO,B0,DIPL,MLT,ALT,DDD,DNH,3,NNH)
C     normalization
      NTOT=NOH+NHH+NHEH+NNH
      NOH=NOH/NTOT
      NHH=NHH/NTOT
      NHEH=NHEH/NTOT
      NNH=NNH/NTOT
C     interpolation (in logarithm)
      IF (F107 .GT. 220) F107=220
	IF (F107 .LT. 65) F107=65
      NO=(ALOG10(NOH)-ALOG10(NOL))/(200.0-85.0)*(F107-85.0)+ALOG10(NOL)
      NH=(ALOG10(NHH)-ALOG10(NHL))/(200.0-85.0)*(F107-85.0)+ALOG10(NHL)
      NHE=(ALOG10(NHEH)-ALOG10(NHEL))/(200.0-85.0)*(F107-85.0)+
     &     ALOG10(NHEL)
      NN=(ALOG10(NNH)-ALOG10(NNL))/(200.0-85.0)*(F107-85.0)+ALOG10(NNL)
C     percentages
      NO=10**NO
      NH=10**NH
      NHE=10**NHE
      NN=10**NN
C     last normalization
      NTOT=NO+NH+NHE+NN
      NO=NO/NTOT
      NH=NH/NTOT
      NHE=NHE/NTOT
      NN=NN/NTOT
      RETURN
      END
C
C
      SUBROUTINE IONLOW(CRD,INVDIP,FL,DIMO,B0,
     &                   DIPL,MLT,ALT,DDD,D,ION,NION)
C---------------------------------------------------------------------------
C IONLOW calculates relative density of O+, H+, He+ or N+  in the outer
C ionosphere for a low solar activity (F107 < 100).
C Based on spherical harmonics approximation of relative ion density
C (by AE-C, and AE-E) at altitudes centred on 400km, 650km, and 1000km.
C For intermediate altitudes an interpolation is used. 
C Recommended altitude range: 350-2000 km!!!
C For days between seasons centred at (21.3. = 79; 21.6. = 171;
C 23.9. 265; 21.12. = 354) relative ion density is linearly interpolated.
C Inputs: CRD - 0 .. INVDIP
C               1 .. FL, DIMO, B0, DIPL (used for calculation INVDIP inside)
C         INVDIP - "mix" coordinate of the dip latitude and of
C                    the invariant latitude;
C                    positive northward, in deg, range <-90.0;90.0>
C         FL, DIMO, BO - McIlwain L parameter, dipole moment in
C                        Gauss, magnetic field strength in Gauss -
C                        parameters needed for invariant latitude
C                        calculation
C         DIPL - dip latitude
C                positive northward, in deg, range <-90.0;90.0>
C         MLT - magnetic local time (central dipole)
C               in hours, range <0;24)
C         ALT - altitude above the Earth's surface;
C               in km, range <350;2000>
C         DDD - day of year; range <0;365>
C         D - coefficints of spherical harmonics for a given ion
C         ION - ion species (0...O+, 1...H+, 2...He+, 3...N+)
C Output: NION - relative density for a given ion 
C---------------------------------------------------------------------------
      REAL INVDIP,FL,DIMO,B0,DIPL,MLT,ALT,NION
      INTEGER CRD,DDD,ION
      DIMENSION  D(3,3,49),MIRREQ(49)
      REAL INVDP,INVDPC,DTOR
      REAL RMLT,RCOLAT
      REAL C(49),C1(82)
      INTEGER SEZA,SEZB,SEZAI,SEZBI,DDDA,DDDB,DDDD
      REAL N0A400,N0B400,N400A,N400B,N400
      REAL N0A650,N0B650,N650A,N650B,N650
      REAL N0A100,N0B100,N100A,N100B,N1000
	REAL ANO(3),AH(3),DNO(1),ST(2)
	COMMON/ARGEXP/ARGMAX
	DATA (MIRREQ(J),J=1,49)/
     &            1,-1, 1,-1, 1,-1, 1, 1,-1, 1,-1, 1,-1, 1,-1, 1,-1,
     &            1,-1, 1,-1, 1,-1, 1, 1,-1, 1,-1, 1, 1,-1, 1,-1, 1,
     &           -1, 1,-1, 1,-1, 1, 1,-1, 1, 1,-1, 1,-1, 1, 1/
C////////////////////////////////////////////////////////////////////////////////////
      DTOR=3.1415926536/180.0
C     coefficients for mirroring
      DO 10 I=1,49
       D(1,3,I)=D(1,2,I)*MIRREQ(I)
       D(2,3,I)=D(2,2,I)*MIRREQ(I)
10     D(3,3,I)=D(3,2,I)*MIRREQ(I)
      IF (CRD .EQ. 1) THEN
       INVDP=INVDPC(FL,DIMO,B0,DIPL,DTOR)
      ELSE IF	(CRD .EQ. 0) THEN
       INVDP=INVDIP
      ELSE
       RETURN
      END IF
      RMLT=MLT*DTOR*15.0
      RCOLAT=(90.0-INVDP)*DTOR
      CALL SPHARM_IK(C1,6,6,RCOLAT,RMLT)
      do i=1,49
      	c(i)=c1(i)
      	enddo
C     21.3. - 20.6.
      IF ((DDD .GE. 79) .AND. (DDD .LT. 171)) THEN
       SEZA=1
       SEZB=2
       DDDA=79
       DDDB=171
       DDDD=DDD
      END IF
C     21.6. - 22.9.
      IF ((DDD .GE. 171) .AND. (DDD .LT. 265)) THEN
       SEZA=2
       SEZB=4
       DDDA=171
       DDDB=265
       DDDD=DDD
      END IF
C     23.9. - 20.12.
      IF ((DDD .GE. 265) .AND. (DDD .LT. 354)) THEN
       SEZA=4
       SEZB=3
       DDDA=265
       DDDB=354
       DDDD=DDD
      END IF
C     21.12. - 20.3.
      IF ((DDD .GE. 354) .OR. (DDD .LT. 79)) THEN
       SEZA=3
       SEZB=1
       DDDA=354
       DDDB=365+79
       DDDD=DDD
        IF (DDD .GE. 354) THEN
         DDDD=DDD
        ELSE
         DDDD=DDD+365
        END IF
      END IF
       SEZAI=MOD(SEZA-1,3)+1
       SEZBI=MOD(SEZB-1,3)+1
C     400km level
        N0A400=0.0
        N0B400=0.0
        DO 30 I=1,49
         N0A400=N0A400+C(I)*D(1,SEZAI,I)
30       N0B400=N0B400+C(I)*D(1,SEZBI,I)
        N400A=N0A400
        N400B=N0B400
        N400=(N400B-N400A)/(DDDB-DDDA)*(DDDD-DDDA)+N400A
C     650km level
      N0A650=0.0
	N0B650=0.0
	DO 70 I=1,49
         N0A650=N0A650+C(I)*D(2,SEZAI,I)
70       N0B650=N0B650+C(I)*D(2,SEZBI,I)
	N650A=N0A650
	N650B=N0B650
	N650=(N650B-N650A)/(DDDB-DDDA)*(DDDD-DDDA)+N650A
C     1000km level
      N0A100=0.0
      N0B100=0.0
	DO 110 I=1,49
         N0A100=N0A100+C(I)*D(3,SEZAI,I)
110      N0B100=N0B100+C(I)*D(3,SEZBI,I)
	N100A=N0A100
	N100B=N0B100
	N1000=(N100B-N100A)/(DDDB-DDDA)*(DDDD-DDDA)+N100A
          
C      IF (ALT .LT. 650) NO=(N650-N400)/250.0*(ALT-400)+N400
C      IF (ALT .GE. 650) NO=(N1000-N650)/350.0*(ALT-650)+N650

C      NION=10**NO

C-02/07/09- n(O+) AND n(N+) must not increase above 650km
      IF (((ION .EQ. 0) .OR. (ION .EQ. 3)) .AND. (N1000 .GT. N650))
     &      N1000=N650
C-02/07/09- n(H+) must not decrease above 650km
      IF ((ION .EQ. 1) .AND. (N1000 .LT. N650)) N1000=N650

      ANO(1)=N400
	 ANO(2)=N650
	  ANO(3)=N1000
	  
	AH(1)=400.
       AH(2)=650.
        AH(3)=1000.
      
      DNO(1)=20.
      
      ST1=(ANO(2)-ANO(1))/(AH(2)-AH(1))
      I=2
      ST2=(ANO(I+1)-ANO(I))/(AH(I+1)-AH(I))
      ANO(I)=ANO(I)-(ST2-ST1)*DNO(I-1)*ALOG(2.)

      DO 220 I=1,2
220   ST(I)=(ANO(I+1)-ANO(I))/(AH(I+1)-AH(I))

      ARGMAX=88.0
      SUM=ANO(1)+ST(1)*(ALT-AH(1))                     
     
      I=1
	aa = eptr(alt  ,dno(i),ah(i+1))
	bb = eptr(ah(1),dno(i),ah(i+1))
      SUM=SUM+(ST(I+1)-ST(I))*(AA-BB)*DNO(I)
                
      NION=10**SUM       
      RETURN
      END
C
C
      SUBROUTINE IONHIGH(CRD,INVDIP,FL,DIMO,B0,
     &                   DIPL,MLT,ALT,DDD,D,ION,NION)
C---------------------------------------------------------------------------
C IONHIGH calculates relative density of O+, H+, He+ or N+  in the outer
C ionosphere for high solar activity conditions (F107 >= 100).
C Based on spherical harmonics approximation of relative ion density
C (by IK24) at altitudes centred on 550km, 900km, 1500km, and 2250km.
C For intermediate altitudes a interpolation is used. 
C Recommended altitude range: 500-3000 km!!!
C For days between seasons centred at (21.3. = 79; 21.6. = 171;
C 23.9. 265; 21.12. = 354) relative ion density is linearly interpolated.
C Inputs: CRD - 0 .. INVDIP
C               1 .. FL, DIMO, B0, DIPL (used for calculation INVDIP inside)
C         INVDIP - "mix" coordinate of the dip latitude and of
C                    the invariant latitude;
C                    positive northward, in deg, range <-90.0;90.0>
C         FL, DIMO, BO - McIlwain L parameter, dipole moment in
C                        Gauss, magnetic field strength in Gauss -
C                        parameters needed for invariant latitude
C                        calculation
C         DIPL - dip latitude
C                positive northward, in deg, range <-90.0;90.0>
C         MLT - magnetic local time (central dipole)
C               in hours, range <0;24)
C         ALT - altitude above the Earth's surface;
C               in km, range <500;3000>
C         DDD - day of year; range <0;365>
C         D - coefficints of spherical harmonics for a given ion
C         ION - ion species (0...O+, 1...H+, 2...He+, 3...N+)
C Output: NION - relative density for a given ion 
C---------------------------------------------------------------------------
      REAL INVDIP,FL,DIMO,B0,DIPL,MLT,ALT,NION
	INTEGER CRD,DDD,ION
      DIMENSION  D(4,3,49),MIRREQ(49)
      REAL INVDP,INVDPC,DTOR
      REAL RMLT,RCOLAT
      REAL C(49),C1(82)
      INTEGER SEZA,SEZB,SEZAI,SEZBI,DDDA,DDDB,DDDD
      REAL N0A550,N0B550,N550A,N550B,N550
      REAL N0A900,N0B900,N900A,N900B,N900
      REAL N0A150,N0B150,N150A,N150B,N1500
      REAL N0A250,N0B250,N250A,N250B,N2500
	REAL ANO(4),AH(4),DNO(2),ST(3)
	COMMON/ARGEXP/ARGMAX
	DATA (MIRREQ(J),J=1,49)/
     &            1,-1, 1,-1, 1,-1, 1, 1,-1, 1,-1, 1,-1, 1,-1, 1,-1,
     &            1,-1, 1,-1, 1,-1, 1, 1,-1, 1,-1, 1, 1,-1, 1,-1, 1,
     &           -1, 1,-1, 1,-1, 1, 1,-1, 1, 1,-1, 1,-1, 1, 1/
C////////////////////////////////////////////////////////////////////////////////////
      DTOR=3.1415926536/180.0
C     coefficients for mirroring
      DO 10 I=1,49
       D(1,3,I)=D(1,2,I)*MIRREQ(I)
       D(2,3,I)=D(2,2,I)*MIRREQ(I)
       D(3,3,I)=D(3,2,I)*MIRREQ(I)
10     D(4,3,I)=D(4,2,I)*MIRREQ(I)
      IF (CRD .EQ. 1) THEN
       INVDP=INVDPC(FL,DIMO,B0,DIPL,DTOR)
      ELSE IF	(CRD .EQ. 0) THEN
       INVDP=INVDIP
      ELSE
       RETURN
      END IF
      RMLT=MLT*DTOR*15.0
      RCOLAT=(90.0-INVDP)*DTOR
      CALL SPHARM_IK(C1,6,6,RCOLAT,RMLT)
      do i=1,49
      	c(i)=c1(i)
      	enddo
C     21.3. - 20.6.
      IF ((DDD .GE. 79) .AND. (DDD .LT. 171)) THEN
       SEZA=1
       SEZB=2
       DDDA=79
       DDDB=171
       DDDD=DDD
      END IF
C     21.6. - 22.9.
      IF ((DDD .GE. 171) .AND. (DDD .LT. 265)) THEN
       SEZA=2
       SEZB=4
       DDDA=171
       DDDB=265
       DDDD=DDD
      END IF
C     23.9. - 20.12.
      IF ((DDD .GE. 265) .AND. (DDD .LT. 354)) THEN
       SEZA=4
       SEZB=3
       DDDA=265
       DDDB=354
       DDDD=DDD
      END IF
C     21.12. - 20.3.
      IF ((DDD .GE. 354) .OR. (DDD .LT. 79)) THEN
       SEZA=3
       SEZB=1
       DDDA=354
       DDDB=365+79
       DDDD=DDD
        IF (DDD .GE. 354) THEN
         DDDD=DDD
        ELSE
         DDDD=DDD+365
        END IF
      END IF
       SEZAI=MOD(SEZA-1,3)+1
       SEZBI=MOD(SEZB-1,3)+1
C     550km level
        N0A550=0.0
        N0B550=0.0
        DO 30 I=1,49
         N0A550=N0A550+C(I)*D(1,SEZAI,I)
30       N0B550=N0B550+C(I)*D(1,SEZBI,I)
        N550A=N0A550
        N550B=N0B550
        N550=(N550B-N550A)/(DDDB-DDDA)*(DDDD-DDDA)+N550A
C     900km level
      N0A900=0.0
	N0B900=0.0
	DO 70 I=1,49
         N0A900=N0A900+C(I)*D(2,SEZAI,I)
70       N0B900=N0B900+C(I)*D(2,SEZBI,I)
	N900A=N0A900
	N900B=N0B900
	N900=(N900B-N900A)/(DDDB-DDDA)*(DDDD-DDDA)+N900A
C     1500km level
      N0A150=0.0
      N0B150=0.0
	DO 110 I=1,49
         N0A150=N0A150+C(I)*D(3,SEZAI,I)
110      N0B150=N0B150+C(I)*D(3,SEZBI,I)
	N150A=N0A150
	N150B=N0B150
	N1500=(N150B-N150A)/(DDDB-DDDA)*(DDDD-DDDA)+N150A
C     2500km level
      N0A250=0.0
	N0B250=0.0
       DO 150 I=1,49
        N0A250=N0A250+C(I)*D(4,SEZAI,I)
150     N0B250=N0B250+C(I)*D(4,SEZBI,I)
       N250A=N0A250
       N250B=N0B250
       N2500=(N250B-N250A)/(DDDB-DDDA)*(DDDD-DDDA)+N250A

C      IF (ALT .LT. 900) NO=(N900-N550)/350.0*(ALT-550)+N550
C      IF ((ALT .GE. 900) .AND. (ALT .LT. 1500))
C     &  NO=(N1500-N900)/600.0*(ALT-900)+N900
c      IF (ALT .GE. 1500) NO=(N2500-N1500)/1000.0*(ALT-1500)+N1500

C     O+ AND N+ may not increase above 1500km 
      IF (((ION .EQ. 0) .OR. (ION .EQ. 3)) .AND. (N2500 .GT. N1500)) 
     & N2500=N1500
C     H+ may not decrease above 1500km 
      IF ((ION .EQ. 1) .AND. (N2500 .LT. N1500)) N2500=N1500
                   
      ANO(1)=N550
	 ANO(2)=N900
	  ANO(3)=N1500
	   ANO(4)=N2500

	AH(1)=550.
       AH(2)=900.
        AH(3)=1500.
         AH(4)=2250.
      DNO(1)=20.
       DNO(2)=20.

      ST1=(ANO(2)-ANO(1))/(AH(2)-AH(1))
      DO 200 I=2,3
       ST2=(ANO(I+1)-ANO(I))/(AH(I+1)-AH(I))
       ANO(I)=ANO(I)-(ST2-ST1)*DNO(I-1)*ALOG(2.)
200   ST1=ST2

      DO 220 I=1,3
220   ST(I)=(ANO(I+1)-ANO(I))/(AH(I+1)-AH(I))

      ARGMAX=88.0
      SUM=ANO(1)+ST(1)*(ALT-AH(1))                     
     
      DO 230 I=1,2
	aa = eptr(alt  ,dno(i),ah(i+1))
	bb = eptr(ah(1),dno(i),ah(i+1))
230   SUM=SUM+(ST(I+1)-ST(I))*(AA-BB)*DNO(I)
                
      NION=10**SUM       
      RETURN
      END
C
C
      REAL FUNCTION INVDPC(FL,DIMO,B0,DIPL,DTOR)
C---------------------------------------------------------------------------
C      calculation of INVDIP from FL, DIMO, BO, and DIPL
C      invariant latitude calculated by highly
C      accurate polynomial expansion
C---------------------------------------------------------------------------
      REAL FL,DIMO,B0,DIPL
	DOUBLE PRECISION B(8),A
      REAL DTOR,ASA,INVL,RINVL,RDIPL,ALFA,BETA
      DATA B/1.259921D0  ,-0.1984259D0 ,-0.04686632D0,-0.01314096D0,
     &      -0.00308824D0, 0.00082777D0,-0.00105877D0, 0.00183142D0/
       A=(DIMO/B0)**(1.0D0/3.0D0)/FL
       ASA=A*(B(1)+B(2)*A+B(3)*A**2+B(4)*A**3+B(5)*A**4+
     &        B(6)*A**5+B(7)*A**6+B(8)*A**7)
       IF (ASA .GT. 1.0) ASA=1.0
       IF (ASA .LT. 0.0) ASA=0.0
C      invariant latitude (absolute value)
       RINVL=ACOS(SQRT(ASA))
       INVL=RINVL/DTOR
       RDIPL=DIPL*DTOR
       ALFA=SIN(ABS(RDIPL))**3
       BETA=COS(RINVL)**3
       INVDPC=(ALFA*SIGN(1.0,DIPL)*INVL+BETA*DIPL)/(ALFA+BETA)
      RETURN
      END
C
C                     
C*************************************************************                  
C************* PEAK VALUES ELECTRON DENSITY ******************                  
C*************************************************************                  
C
C
      real function FOUT(XMODIP,XLATI,XLONGI,UT,FF0)
c--------------------------------------------------------------
C CALCULATES CRITICAL FREQUENCY FOF2/MHZ USING SUBROUTINE GAMMA1.      
C XMODIP = MODIFIED DIP LATITUDE, XLATI = GEOG. LATITUDE, XLONGI=
C LONGITUDE (ALL IN DEG.), MONTH = MONTH, UT =  UNIVERSAL TIME 
C (DEC. HOURS), FF0 = ARRAY WITH RZ12-ADJUSTED CCIR/URSI COEFF.
C D.BILITZA,JULY 85.
c--------------------------------------------------------------
      DIMENSION FF0(988)
      INTEGER QF(9)
      DATA QF/11,11,8,4,1,0,0,0,0/
      FOUT=GAMMA1(XMODIP,XLATI,XLONGI,UT,6,QF,9,76,13,988,FF0)
      RETURN
      END
C
C
      real function XMOUT(XMODIP,XLATI,XLONGI,UT,XM0)
c--------------------------------------------------------------
C CALCULATES PROPAGATION FACTOR M3000 USING THE SUBROUTINE GAMMA1.
C XMODIP = MODIFIED DIP LATITUDE, XLATI = GEOG. LATITUDE, XLONGI=
C LONGITUDE (ALL IN DEG.), MONTH = MONTH, UT =  UNIVERSAL TIME 
C (DEC. HOURS), XM0 = ARRAY WITH RZ12-ADJUSTED CCIR/URSI COEFF.
C D.BILITZA,JULY 85.
c--------------------------------------------------------------
      DIMENSION XM0(441)
      INTEGER QM(7)
      DATA QM/6,7,5,2,1,0,0/
      XMOUT=GAMMA1(XMODIP,XLATI,XLONGI,UT,4,QM,7,49,9,441,XM0)
      RETURN
      END
C
C
      REAL FUNCTION HMF2ED(XMAGBR,R,X,XM3)         
c--------------------------------------------------------------
C CALCULATES THE PEAK HEIGHT HMF2/KM FOR THE MAGNETIC                           
C LATITUDE XMAGBR/DEGREE AND THE SMOOTHED ZUERICH SUNSPOT                         
C NUMBER R USING CCIR-M3000 XM3 AND THE RATIO X=FOF2/FOE.
C FOLLOWING CCIR RECOMMENDATION X IS LIMITED TO VALUE
C GREATER OR EQUAL TO 1.7 .                       
C [REF. D.BILITZA ET AL., TELECOMM.J., 46, 549-553, 1979]                       
C D.BILITZA,1980.     
c--------------------------------------------------------------
      F1=0.00232*R+0.222                         
      F2=1.2-0.0116*EXP(0.0239*R)            
      F3=0.096*(R-25.0)/150.0                      
      F4=1.0-R/150.0*EXP(-XMAGBR*XMAGBR/1600.0)
      if(x.lt.1.7) x=1.7
      DELM=F1*F4/(X-F2)+F3                
      HMF2ED=1490.0/(XM3+DELM)-176.0 
      RETURN          
      END             
C
C
      REAL FUNCTION XM3000HM(XMAGBR,R,X,HMF2)         
c--------------------------------------------------------------
C CALCULATES THE PROPAGATION FACTOR M3000 FOR THE MAGNETIC LATITUDE
C XMAGBR/DEG. AND THE SMOOTHED ZUERICH SUNSPOT NUMBER R USING THE                        
C PEAK HEIGHT HMF2/KM AND THE RATIO X=FOF2/FOE. Reverse of HMF2ED.                      
C [REF. D.BILITZA ET AL., TELECOMM.J., 46, 549-553, 1979]                       
C D.BILITZA,1980. ----- no longer used    
c--------------------------------------------------------------
      F1=0.00232*R+0.222                         
      F2=1.2-0.0116*EXP(0.0239*R)            
      F3=0.096*(R-25.0)/150.0                      
      F4=1.0-R/150.0*EXP(-XMAGBR*XMAGBR/1600.0)
      if(x.lt.1.7) x=1.7
      DELM=F1*F4/(X-F2)+F3                
	  XM3000HM=1490.0/(HMF2+176.0)-DELM
      RETURN          
      END             
C
C
      REAL FUNCTION FOF1ED(YLATI,R,CHI)
c--------------------------------------------------------------
C CALCULATES THE F1 PEAK PLASMA FREQUENCY (FOF1/MHZ)
C INPUT:   
C		YLATI	ABSOLUT VALUE OF DIP-LATITUDE IN DEGREE
c       R		12-MONTH RUNNING MEAN OF SUNSPOT NUMBER 
c       CHI		SOLAR ZENITH ANGLE IN DEGREE
C REFERENCE: 
c       E.D.DUCHARME ET AL., RADIO SCIENCE 6, 369-378, 1971
C                                      AND 8, 837-839, 1973
c       HOWEVER WITH MAGNETIC DIP LATITUDE INSTEAD OF GEOMAGNETIC
c       DIPOLE LATITUDE, EYFRIG, 1979                    
C--------------------------------------------- D. BILITZA, 1988.   
        COMMON/CONST/UMR
	    fof1ed=0.0
	    if (chi.gt.90.0) return

        DLA =  YLATI
        F0 = 4.35 + DLA * ( 0.0058 - 1.2E-4 * DLA ) 
        F100 = 5.348 + DLA * ( 0.011 - 2.3E-4 * DLA )
        FS = F0 + ( F100 - F0 ) * R / 100.0
        XMUE = 0.093 + DLA * ( 0.0046 - 5.4E-5 * DLA ) + 3.0E-4 * R
        FOF1 = FS * COS( CHI * UMR ) ** XMUE
                CHI0 = 49.84733 + 0.349504 * DLA
                CHI100 = 38.96113 + 0.509932 * DLA
                CHIM = ( CHI0 + ( CHI100 - CHI0 ) * R / 100. )
                IF(CHI.GT.CHIM) FOF1=-FOF1 
        FOF1ED = FOF1     
        RETURN
        END             
C
C
	real function f1_c1(xmodip,hour,suxnon,saxnon)
c F1 layer shape parameter C1 after Reinisch and Huang, Advances in
c Space Research, Volume 25, Number 1, 81-88, 2000.

        common	/const/umr
        pi = umr * 180.
	
        ABSMDP=ABS(XMODIP)
      	DELA=4.32
      	IF(ABSMDP.GE.18.) DELA=1.0+EXP(-(ABSMDP-30.0)/10.0)

      	C1OLD = 0.09 + 0.11/DELA
        if(suxnon.eq.saxnon) then
            c1 = 2.5 * c1old
        else
            c1 = 2.5*c1old*cos((HOUR-12.)/(suxnon-saxnon)*pi)
        endif
      	if(c1.lt.0.0) c1=0.0
	    f1_c1=c1
	    return
	    end
c
c
        subroutine f1_prob (sza,glat,rz12,f1prob,f1probl)
c--------------------------------------------------------------------------
c Occurrence probability of F1 layer after Scotto et al., Advances in
c Space Research, Volume 20, Number 9, 1773-1775, 1997.
c
c Input: 	sza		solar zenith angle in degrees 
c 			glat	geomagnetic latitude in degrees
C			rz12	12-month running mean of sunspot number
c Output: 	f1prob	F1 occurrence probability without L-condition cases 
c 			f1probl	F1 occurrence probability with L-condition cases
c--------------------------------------------------------------------------
c
        common /const/umr

	    xarg = 0.5 + 0.5 * cos(sza*umr)
		a = 2.98 + 0.0854 * rz12
		b = 0.0107 - 0.0022 * rz12
		c = -0.000256 + 0.0000147 * rz12
		gamma = a + ( b + c * glat) * glat
	    f1pr = xarg ** gamma
        if(f1pr.lt.1.e-3) f1pr=0.0
        f1prob=f1pr
	    f1prl = xarg ** 2.36
        if(f1prl.lt.1.e-3) f1prl=0.0
        f1probl=f1prl
	    return
	    end
C
C
        REAL FUNCTION FOEEDI(COV,XHI,XHIM,XLATI)
C-------------------------------------------------------
C CALCULATES FOE/MHZ BY THE EDINBURGH-METHOD.      
C INPUT: 
C 	COV		MONTHLY MEAN 10.7CM SOLAR RADIO FLUX measured at 
C           ground level  
C   XHI		SOLAR ZENITH ANGLE IN DEGREE 
C   XHIM	SOLAR ZENITH ANGLE AT NOON IN DEGREE
C   XLATI 	ABSOLUTE VALUE OF GEOGRAPHIC LATITUDE IN DEGREE, 
C REFERENCE: 
C       KOURIS-MUGGELETON, CCIR DOC. 6/3/07, 1973
C       TROST, J. GEOPHYS. RES. 84, 2736, 1979 (was used
C               to improve the nighttime varition)
C       RAWER AND BILITZA, Adv. Space Res. 10(8), 5-14, 1990
C D.BILITZA--------------------------------- AUGUST 1986.    
        COMMON/CONST/UMR
C variation with solar activity (factor A) ...............
        A=1.0+0.0094*(COV-66.0)                      
C variation with noon solar zenith angle (B) and with latitude (C)
        SL=COS(XLATI*UMR)
        IF(XLATI.LT.32.0) THEN
                SM=-1.93+1.92*SL                             
                C=23.0+116.0*SL                              
        ELSE
                SM=0.11-0.49*SL                              
                C=92.0+35.0*SL  
        ENDIF
        if(XHIM.ge.90.) XHIM=89.999
        B = COS(XHIM*UMR) ** SM
C variation with solar zenith angle (D) ..........................        
        IF(XLATI.GT.12.0) THEN
                SP=1.2
        ELSE
                SP=1.31         
        ENDIF
C adjusted solar zenith angle during nighttime (XHIC) .............
        XHIC=XHI-3.*ALOG(1.+EXP((XHI-89.98)/3.))   
        D=COS(XHIC*UMR)**SP       
C determine foE**4 ................................................
        R4FOE=A*B*C*D     
C minimum allowable foE (foe_min=sqrt[SMIN])...............................
        SMIN=0.121+0.0015*(COV-60.)
        SMIN=SMIN*SMIN
        IF(R4FOE.LT.SMIN) R4FOE=SMIN                     
        FOEEDI=R4FOE**0.25                           
        RETURN          
        END   
C
C
        REAL FUNCTION XMDED(XHI,R,YW)                
C D. BILITZA, 1978, CALCULATES ELECTRON DENSITY OF D MAXIMUM.                   
C XHI/DEG. IS SOLAR ZENITH ANGLE, R SMOOTHED ZURICH SUNSPOT NUMBER              
C AND YW/M-3 THE ASSUMED CONSTANT NIGHT VALUE.     
C [REF.: D.BILITZA, WORLD DATA CENTER A REPORT UAG-82,7,BOULDER,1981]
C corrected 4/25/97 - D. Bilitza
c
        COMMON/CONST/UMR
c
        if(xhi.ge.90) goto 100
        Y = 6.05E8 + 0.088E8 * R
        yy = cos ( xhi * umr )
        yyy = -0.1 / ( yy**2.7 ) 
        if (yyy.lt.-40.) then 
        	ymd=0.0
        else
        	ymd = y * exp(yyy)
        endif
        if (ymd.lt.yw) ymd = yw
        xmded=ymd
        RETURN          

100     XMDED=YW        
        RETURN          
        END
C
C
        REAL FUNCTION GAMMA1(SMODIP,SLAT,SLONG,HOUR,
     &                          IHARM,NQ,K1,M,MM,M3,SFE)      
C---------------------------------------------------------------
C CALCULATES GAMMA1=FOF2 OR M3000 USING CCIR NUMERICAL MAP                      
C COEFFICIENTS SFE(M3) FOR MODIFIED DIP LATITUDE (SMODIP/DEG)
C GEOGRAPHIC LATITUDE (SLAT/DEG) AND LONGITUDE (SLONG/DEG)  
C AND UNIVERSIAL TIME (HOUR/DECIMAL HOURS). IHARM IS THE MAXIMUM
C NUMBER OF HARMONICS USED FOR DESCRIBING DIURNAL VARIATION.
C NQ(K1) IS AN INTEGER ARRAY GIVING THE HIGHEST DEGREES IN 
C LATITUDE FOR EACH LONGITUDE HARMONIC WHERE K1 GIVES THE NUMBER 
C OF LONGITUDE HARMONICS. M IS THE NUMBER OF COEFFICIENTS FOR 
C DESCRIBING VARIATIONS WITH SMODIP, SLAT, AND SLONG. MM IS THE
C NUMBER OF COEFFICIENTS FOR THE FOURIER TIME SERIES DESCRIBING
C VARIATIONS WITH UT.
C M=1+NQ(1)+2*[NQ(2)+1]+2*[NQ(3)+1]+... , MM=2*IHARM+1, M3=M*MM  
C SHEIKH,4.3.77.      
C---------------------------------------------------------------
      REAL*8 C(12),S(12),COEF(100),SUM             
      DIMENSION NQ(K1),XSINX(13),SFE(M3)           
      COMMON/CONST/UMR
      HOU=(15.0*HOUR-180.0)*UMR                    
      S(1)=SIN(HOU)   
      C(1)=COS(HOU)   

      DO 250 I=2,IHARM                             
        C(I)=C(1)*C(I-1)-S(1)*S(I-1)                 
        S(I)=C(1)*S(I-1)+S(1)*C(I-1)                 
250     CONTINUE        

      DO 300 I=1,M    
        MI=(I-1)*MM     
        COEF(I)=SFE(MI+1)                            
        DO 300 J=1,IHARM                             
          COEF(I)=COEF(I)+SFE(MI+2*J)*S(J)+SFE(MI+2*J+1)*C(J)                       
300       CONTINUE        

      SUM=COEF(1)     
      SS=SIN(SMODIP*UMR)                           
      S3=SS           
      XSINX(1)=1.0    
      INDEX=NQ(1)     

      DO 350 J=1,INDEX                             
        SUM=SUM+COEF(1+J)*SS                         
        XSINX(J+1)=SS   
        SS=SS*S3        
350     CONTINUE        

      XSINX(NQ(1)+2)=SS                            
      NP=NQ(1)+1      
      SS=COS(SLAT*UMR)                             
      S3=SS           

      DO 400 J=2,K1   
        S0=SLONG*(J-1.)*UMR                          
        S1=COS(S0)      
        S2=SIN(S0)      
        INDEX=NQ(J)+1   
        DO 450 L=1,INDEX                             
          NP=NP+1         
          SUM=SUM+COEF(NP)*XSINX(L)*SS*S1              
          NP=NP+1         
          SUM=SUM+COEF(NP)*XSINX(L)*SS*S2              
450       CONTINUE        
        SS=SS*S3        
400     CONTINUE
        
      GAMMA1=SUM      

      RETURN          
      END 
C
C                     
C************************************************************                   
C***************** PROFILE PARAMETERS ***********************                   
C************************************************************                 
C
C

	      SUBROUTINE TOPH05(COVI,AMLAT,TIME,HMAX,HT05,SG)
C---------------------------------------------------------------------------------
C Gulyaeva T.L. (2003) Variations in the half-width of the topside ionosphere 
C    according to the observations by space ionosondes ISIS 1,ISIS 2, and IK19.
C    International J. of Geomagnetism and Aeronomy, 4(3), 201-207.
C Gulyaeva T.L., Titheridge J.E. (2006) Advanced specification of electron density 
C    and temperature in the IRI ionosphere-plasmasphere model. 
C    Adv. Space Res. 38(11), 2587-2595, doi:10.1016/j.asr.2005.08.045.
C
C  Implementation of empirical RAT=(h05top-hmF2)/hmF2 derived from ISIS and IK19
C  topside electron density profiles to obtain half peak density topside height
C  h05top  from the Chebishev polinomial coefficients given for 
C  (1) 4 levels of solar activity: Rz= 0,  50, 100, 150 replaced by
C      solar radio flux          covi=60, 106, 152, 198
C  (2) 10 selected grids of geomagnetic latitude (N=S):0,10,20,30,40,50,60,70,80,90
C  (3) 5 selected grids of local time: 0, 6, 12, 18, 24.
C  (4) 4 seasonal grids: 1 equinox(SG=90deg), 2 summer (SG=180), 
C                        3 equinox (SG=270), 4 winter(SG=360)
C   SG=season grids=90,180,270,360
C---------------------------------------------------------------------------------
      DIMENSION CVLEV(4)	
	  COMMON     /BLOCK1/HMF2,XNMF2,XHMF1,F1REG         
     *         /QTOP/Y05,H05TOP,QF,XNETOP,XM3000,HHALF,TAU
	  DATA CVLEV/60.,106.,152.,198./
	  LOGICAL F1REG

	  ABMLAT=ABS(AMLAT)
       IR=IFIX((covi-60.)/46.)+1	
		 M1=IFIX(ABMLAT/10.)+1
			L1=IFIX(TIME/6.)+1
	  M2=M1+1
	       IF(M1.EQ.10) M2=10
        L2=L1+1
	       IF(L1.EQ.5) L2=5
C
C INTERPOLATE RAT FOR GIVEN RZI
C Call Chebishev approximation to interpolate for given ABMLAT, HRLT
C
	  call CHEBISH(CVLEV(IR),TIME,ABMLAT,XX,SG)
        IF (IR.EQ.4) THEN
	          RAT05=XX
	          GOTO 10
	          ENDIF
	  call CHEBISH(CVLEV(IR+1),TIME,ABMLAT,YY,SG)
	  RAT05=XX+(YY-XX)*(COVI-CVLEV(IR))/46.
10    HT05=HMAX*(1.+RAT05)
	  RETURN
	  END
C
C	  
	SUBROUTINE CHEBISH(COVS,HOURLT,ABMLAT,RATCH,SG)
C---------------------------------------------------------------------------------
C CHEBISHEV POLINOMIALS FOR ABMLAT(10),HOURLT(5)
C CR((C0...C5),(LT=0,6,...24),(SG=season grids=90,180,270,360)
C							(COV=60,106,152,198)
C---------------------------------------------------------------------------------
c      REAL UK(0:10),CR(0:5,5,3,4),YI(5),YY(5,3)
      REAL BR(6,5,3,4),YI(5),YY(5,3)
      REAL PL1(5),PL2(5),PL3(5),CL(0:3)
C  
	  DATA rad/0.01745329/
      DATA PL1/-2.,-1.,0.,1.,2./
  	  DATA PL2/2.,-1.,-2.,-1.,2./
  	  DATA PL3/-1.,2.,0.,-2.,1./
      DATA BR/
C Polinomial Coefficients B1,B2,B3,B4,B5,B6 for COV=60 (mlat/10=0,1,...,9)
C Equinox	B0MLAT:
     *  -1.5859,  3.5789, -3.7884, 2.7094,-1.2962,.6759
     *, -5.3449, 12.8379,-12.0165, 5.9746,-1.9084,.7669
     *,-12.8000, 35.3084,-38.0043,19.6004,-4.4974,.6975
     *,  5.8282,-13.3538,  9.1674,-0.9593,-0.8909,.6062
     *, -1.5859,  3.5789, -3.7884, 2.7094,-1.2962,.6759
C Summer	B0MLAT    
     *, -7.1103, 21.0389,-24.5539,14.1607,-3.8537,.7266
     *,  5.5333,-10.6242,  4.8751, 1.0587,-1.0821,.7527
     *,-15.4487, 42.9269,-45.0314,21.4718,-4.2116,.6026
     *, -6.6436, 16.4533,-15.5142, 6.8287,-1.2871,.4976
     *, -7.1103, 21.0389,-24.5539,14.1607,-3.8537,.7266
C Winter   B0MLAT                                                                       
     *, 14.9103,-35.2337, 27.3078,-6.5362,-0.6265,.7509
     *,  2.3846, -5.8840,  3.7023, 0.8525,-1.2663,.7086
     *, -9.8846, 26.6649,-27.0173,12.6959,-2.6536,.6295
     *,  1.7692, -2.3578, -0.7945, 2.2477,-0.9691,.5719
     *, 14.9103,-35.2337, 27.3078,-6.5362,-0.6265,.7509
C Polinomial Coefficients B1,B2,B3,B4,B5,B6 for COV=106 (mlat=0,10,...,90)
C Equinox	B1MLAT
     *, -4.1218, 10.6136,-11.4922, 6.0470,-1.3620,.5563
     *,  0.9077,  2.9562, -8.9880, 6.8680,-1.9621,.7737
     *,-16.2744, 42.8047,-43.7009,20.7965,-4.0697,.6619
     *,-17.3038, 44.3336,-40.9249,15.9042,-2.1554,.4796
     *, -4.1218, 10.6136,-11.4922, 6.0470,-1.3620,.5563
C Summer	B1MLAT  
     *, -4.9692, 16.5753,-21.3543,12.7061,-3.1758,.6446
     *,  1.9000, -2.8167, -0.9962, 3.0687,-1.3454,.6859
     *,  7.6769,-14.8343,  6.7030, 1.5578,-1.0626,.4291
     *,  5.4833,-10.6322,  4.7571, 1.2178,-0.8223,.4615
     *, -4.9692, 16.5753,-21.3543,12.7061,-3.1758,.6446
C Winter	B1MLAT  
     *, -4.7282, 13.4491,-15.6931, 8.8388,-1.9732,.5874
     *,  5.6756,-14.8458, 11.8927,-2.2632,-0.6122,.6948
     *,-14.2872, 40.0829,-41.2716,18.1696,-2.7203,.4916
     *,-13.6128, 33.4657,-29.7231,11.0972,-1.2884,.5034
     *, -4.7282, 13.4491,-15.6931, 8.8388,-1.9732,.5874
C Polinomial Coefficients B1,B2,B3,B4,B5,B6 for COV=152 (mlat=0,10,...,90)
C Equinox	B2MLAT
     *, -3.3282, 10.4296,-12.4722, 6.7623,-1.5172,.4931
     *, -8.9744, 20.1311,-17.4552, 7.6518,-1.7371,.6702
     *, 12.0462,-27.8932, 20.6241,-4.5781, 0.0814,.3501
     *,-17.0551, 42.3258,-37.1874,13.3608,-1.4804,.4216
     *, -3.3282, 10.4296,-12.4722, 6.7623,-1.5172,.4931
C Summer	B2MLAT  
     *,  7.3077,-17.1579, 11.6872,-0.7405,-1.0298,.5754
     *, 19.2641,-45.1886, 34.3297,-8.1879,-0.1875,.6562
     *,  6.0987,-11.0903,  4.3569, 1.4001,-0.7309,.3885
     *,  5.9295,-13.9205, 10.2347,-2.2818, 0.0853,.3915
     *,  7.3077,-17.1579, 11.6872,-0.7405,-1.0298,.5754
C Winter	B2MLAT  
     *, -1.6821,  8.6010,-13.6570, 8.6307,-1.9846,.5635
     *,  5.4679,-12.3750,  7.5620, 0.5394,-1.4415,.6659
     *, -8.0821, 21.9288,-21.8597, 9.3455,-1.4644,.3599
     *, -8.3000, 19.3076,-16.3295, 6.1619,-0.9144,.3846
     *, -1.6821,  8.6010,-13.6570, 8.6307,-1.9846,.5635
C Polinomial Coefficients B1,B2,B3,B4,B5,B6 for COV=198 (mlat=0,10,...,90)
C Equinox	B3MLAT
     *,-16.4051, 28.2880,-16.0982, 4.6328,-1.0405,.5486
     *, 13.0846,-34.8291, 30.0074,-8.6402, 0.1529,.6165
     *, 19.7474,-42.7116, 28.9430,-6.0487, 0.1492,.3748
     *, 16.2795,-36.6982, 26.5094,-6.3492, 0.2926,.3946
     *,-16.4051, 28.2880,-16.0982, 4.6328,-1.0405,.5486
C Summer	B3MLAT
     *,  4.6410,-13.7931, 11.6548,-1.9248,-0.7246,.5264
     *, -2.4090,  3.1805, -2.8423, 2.8861,-0.9937,.5234
     *,  6.3410,-13.9643,  8.2461,-0.0186,-0.7009,.3582
     *,  9.0987,-20.8618, 14.7262,-2.8798,-0.0512,.3662
     *,  4.6410,-13.7931, 11.6548,-1.9248,-0.7246,.5264
C Winter	B3MLAT
     *, -4.6526, 12.1878,-14.4047, 8.5226,-2.0493,.5903
     *,  3.9821, -6.9477,  0.8382, 3.4898,-1.5694,.6283
     *, -7.0474, 17.3974,-17.3465, 8.3671,-1.5708,.3759
     *,  4.2782, -9.9880,  5.9834, 0.0975,-0.4900,.3842
     *, -4.6526, 12.1878,-14.4047, 8.5226,-2.0493,.5903/

C	DATA UL/-2.,-1.,0.,1.,2./

	do k=0,3
	cl(k)=0.
	enddo
C
	IR=IFIX((covs-60.)/46.)+1	
C Given geomagnetic latitude parameter:
	xi=abmlat/100.
	DO LS=1,3
          DO LL=1,5
      B1=BR(6,LL,LS,IR)      
      B2=BR(5,LL,LS,IR)        
      B3=BR(4,LL,LS,IR)       
      B4=BR(3,LL,LS,IR)        
	B5=BR(2,LL,LS,IR)        
	B6=BR(1,LL,LS,IR)        
       HLT=(LL-1)*6.0

      YY(LL,LS)=B1+xi*(B2+xi*(B3+xi*(B4+xi*(B5+xi*B6))))
	ENDDO
	ENDDO            ! end of season/day cycle
C Apply seasonal interpolation
	 do i=1,5
	p0=(2.*YY(i,1)+YY(i,2)+YY(i,3))/4.
	p1=(YY(i,3)-YY(i,2))/2.
	p2=(YY(i,2)+YY(i,3)-2.*YY(i,1))/4.
	YI(i)=p0+p1*cos(sg*rad)+p2*cos(2.*sg*rad)
	 enddo
      DO K=1,5
      CL(0)=CL(0)+YI(K)
      CL(1)=CL(1)+YI(K)*PL1(K)
      CL(2)=CL(2)+YI(K)*PL2(K)
      CL(3)=CL(3)+YI(K)*PL3(K)
	ENDDO
      CL(0)=CL(0)/5.
      CL(1)=CL(1)/10.
      CL(2)=CL(2)/14.
      CL(3)=CL(3)/12.
      ULL=(HOURLT-12.)/6.
      ZA=CL(0)-2.*CL(2)
      RATCH=ZA+ULL*(CL(1)-3.4*CL(3)+ULL*(CL(2)+ULL*CL(3)))

	RETURN
	END	
C
C
	SUBROUTINE  SHAMDB0D (RLAT,FLON,T,RZ,B)
C-------------------------------------------------------------------
C	COMPUTES THE HOURLY VALUES OF B0 FROM A SET OF SH COEFFICIENTS
C	IN A POINT OF A GIVEN GEOCENTRIC LATITUDE AND LONGITUDE
C	OF THE EARTH'S SURFACE FOR A GIVEN MONTH AND A GIVEN SUSPOT NUMER
C
C INPUT:	RLAT    The geogrphic latitude on the meridian given by 
C					the local time (FLON), where the modified dip
C                   latitude is the same as of the orginal site.
C			FLON	=LONGITUDE+15.*UT(hours)
C			T		Month as a REAL number (1.0 to 12.0)
C			RZ		12-month running mean
C OUTOUT	B		=B0
C
C  Blanch E., D. Arrazola, D. Altadill, D. Buresova, M. Mosert, 
C     Adv. Space Res. 39, 701-710, 2007.
C  Altadill, D., D. Arrazola, E. Blanch, D. Buresova, 
C     Adv. Space Res. 42, 610-616, 2008.
C  Altadill, D., J.M. Torta, and E. Blanch, 
C     Adv. Space Res. 43,1825-1834, 2009.
C-------------------------------------------------------------------
      PARAMETER   (IBO=0,JBO=1,KDIM=6,LDIM=4,L=-1)
      DIMENSION   FN(0:KDIM,0:KDIM), CONST(0:KDIM,0:KDIM)
      DIMENSION   GNM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM),
     *			HNM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM)
	  DIMENSION   GANM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM),
     *			HANM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM),
     *            GBNM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM),
     *			HBNM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM)
      DIMENSION   BINT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM),
     *            BEXT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM)
      CHARACTER*1 IE       
      COMMON  BINT,BEXT,RE,TZERO,IFIT,IB,KINT,LINT,KEXT,
     *              LEXT,KMAX,FN
C     ,CONST

      DATA THETA,RE,    TZERO,IFIT,ICEN,IREF,IB,KINT,LINT,KEXT,LEXT
     *     /180.,6371.2,1.0,  -1,  0,   0,   2, 6,   4,   0,   -1/

  	  DATA ((CONST(N,M), M=0,N), N=0,KDIM)
     *	 /4*1.,1.73205,0.866025,1.,2.44949,1.93649,0.7905691,1.,
     *	  3.16228,3.35410,2.09165,0.739510,1.,3.87298,5.12348,
     *	  4.18330,2.21853,0.701561,1.,4.58258,2*7.24569,4.96078,
     *      2.32681,0.671693/

	  DATA IE /"I"/

      DATA (((GANM(N,M,J),GBNM(N,M,J),HANM(N,M,J),HBNM(N,M,J),
     *    	J=0,LDIM), M=0,N), N=0,KDIM)
     * /176.746, 0.233,   0.000, 0.000,
     * -109.413, 0.072,   0.000, 0.000, -66.000,-0.004,   0.000, 0.000,
     *   36.874,-0.018,   0.000, 0.000, -19.515, 0.040,   0.000, 0.000,
     *   94.998, 0.724,   0.000, 0.000,
     * -116.900,-0.971,   0.000, 0.000, -93.849,-0.590,   0.000, 0.000,
     *   80.579, 0.425,   0.000, 0.000, -19.205,-0.220,   0.000, 0.000,
     *  -94.824, 0.115,   6.055, 0.265,
     *   84.720,-0.161,  -7.101,-0.374,  35.200,-0.138,   1.043,-0.350,
     *  -23.960, 0.109,  -2.478, 0.133,  25.550,-0.049,  -3.143, 0.003,
     *  -29.418,-0.823,   0.000, 0.000,
     *   40.070, 0.800,   0.000, 0.000,  24.019, 0.478,   0.000, 0.000,
     *  -13.175,-0.265,   0.000, 0.000,   8.799, 0.090,   0.000, 0.000,
     *  -31.099,-1.117,  -1.906, 0.498,
     *   43.807, 1.406,  -3.216,-0.520,  37.957, 0.902,  -0.717,-0.570,
     *  -40.232,-0.583,  12.171, 0.244,  11.595, 0.241,  -4.890, 0.054,
     *  -87.665, 1.635, 117.581,-1.765,
     *  123.444,-2.119,-146.917, 2.131,  81.137,-1.173, -99.063, 1.548,
     *  -42.646, 0.681,  61.263,-0.811,  17.550,-0.408, -24.374, 0.260,
     *   54.538,-0.170,   0.000, 0.000,
     *  -71.552, 0.361,   0.000, 0.000, -50.565,-0.077,   0.000, 0.000,
     *   36.653,-0.071,   0.000, 0.000, -10.816, 0.236,   0.000, 0.000,
     *  -31.138, 1.156,  37.307,-1.407,
     *   40.390,-1.390, -34.573, 1.730,  41.597,-0.835, -41.318, 1.550,
     *  -19.779, 0.404,  15.954,-0.696,  -1.706,-0.220,   5.084, 0.040,
     *  -57.671, 0.045,  42.683,-0.800,
     *   71.491, 0.048, -49.441, 0.980,  47.893,-0.037, -36.191, 0.562,
     *  -26.638,-0.029,  20.346,-0.384,   9.998, 0.067,  -6.787, 0.213,
     *   90.187,-1.198, -66.032,-0.056,
     * -119.148, 1.428,  81.202, 0.022, -63.375, 0.754,  53.070, 0.149,
     *   39.249,-0.436, -30.898,-0.052, -27.293, 0.301,  12.838,-0.067,
     * -110.261, 1.509,   0.000, 0.000,
     *  164.956,-1.761,   0.000, 0.000, 103.699,-1.005,   0.000, 0.000,
     *  -55.127, 0.569,   0.000, 0.000,  25.376,-0.315,   0.000, 0.000,
     * -104.655, 1.341, 109.057,-1.367,
     *  139.129,-1.730,-127.325, 1.532,  88.526,-1.068,-106.461, 1.397,
     *  -38.306, 0.508,  56.240,-0.798,  17.239,-0.267,  -7.766, 0.058,
     *   -6.494,-1.253,   5.714, 0.132,
     *    3.547, 1.545,  -5.372,-0.106,  -4.343, 1.103,  -3.393,-0.017,
     *    2.454,-0.626,  -3.297,-0.025,   5.871, 0.160,   2.040,-0.036,
     *   50.814,-0.230, -25.094, 0.817,
     *  -65.502, 0.304,  32.267,-1.075, -44.176, 0.019,  14.606,-0.605,
     *   27.869,-0.009,  -5.147, 0.387, -11.041, 0.131,   5.922,-0.225,
     *   77.825,-0.728, 128.501,-0.810,
     *  -87.685, 0.838,-164.016, 1.103, -74.431, 0.807, -95.539, 0.498,
     *   40.631,-0.454,  49.950,-0.292,  -4.229, 0.000, -29.666, 0.272,
     *  152.380,-1.232,   0.000, 0.000,
     * -192.098, 1.514,   0.000, 0.000,-132.417, 1.370,   0.000, 0.000,
     *   82.894,-0.709,   0.000, 0.000, -28.162, 0.050,   0.000, 0.000,
     *  -12.633, 1.192,  47.246,-1.193,
     *   -5.488,-1.387, -67.206, 1.486,  -9.917,-0.914, -34.438, 0.552,
     *   13.185, 0.477,  21.225,-0.387,   0.586,-0.208, -15.426, 0.419,
     *   -4.478,-0.118,  17.908, 0.175,
     *   -0.417, 0.067, -27.047,-0.241,   7.636, 0.028, -10.075,-0.109,
     *  -10.582, 0.005,  14.496, 0.086,   0.421, 0.001, -12.200,-0.041,
     *   16.086, 0.321,  47.044,-0.126,
     *  -24.823,-0.280, -62.615, 0.210, -12.030,-0.136, -44.003,-0.023,
     *    4.929, 0.137,  28.340,-0.009,  -4.688,-0.057,  -9.315, 0.103,
     *   28.023,-0.031, -21.535, 0.115,
     *  -31.946, 0.011,  24.143,-0.180, -21.019,-0.057,  24.108,-0.116,
     *   13.969, 0.004, -13.823, 0.042,  -6.860, 0.031,   0.546,-0.035,
     * 20*0.000,
     *  -31.994, 0.409,   0.000, 0.000,
     *   18.217,-0.458,   0.000, 0.000,  39.280,-0.754,   0.000, 0.000,
     *  -20.453, 0.324,   0.000, 0.000,  -8.111, 0.139,   0.000, 0.000,
     *   28.765,-0.477, -28.368, 0.516,
     *  -50.604, 0.751,  25.725,-0.471, -23.444, 0.283,  29.966,-0.558,
     *    2.759,-0.146, -10.824, 0.341,  -7.419, 0.206,  -3.711, 0.056,
     *   42.429,-0.415,   1.993, 0.117,
     *  -53.162, 0.555,   7.229,-0.246, -19.307, 0.039,  -8.028, 0.028,
     *    9.849,-0.035,   6.834, 0.033, -17.010, 0.272,   4.668,-0.129,
     *    4.546,-0.359, -57.796, 0.359,
     *    0.738, 0.343,  73.027,-0.423,  -7.421, 0.420,  56.067,-0.327,
     *    5.093,-0.279, -37.581, 0.226,   3.636,-0.041,  10.910,-0.059,
     *   88.440,-0.393, -69.598, 0.643,
     * -109.481, 0.532,  82.266,-0.765, -59.229, 0.182,  55.279,-0.580,
     *   28.514,-0.057, -30.282, 0.326, -22.924, 0.164,  11.602,-0.073,
     * 40*0.000/                                

      KMAX = MAX(KINT,KEXT)
      IF (KMAX .GT. KDIM)  GO TO 9999
      KT = MAX(LINT,LEXT)
      IF (KT .GT. LDIM)  GO TO 9999

	DO 500 N=0,KMAX
	DO 500 M=0,N

	DO J=0,KT
	 GNM(N,M,J)=GANM(N,M,J)+GBNM(N,M,J)*rz
	 HNM(N,M,J)=HANM(N,M,J)+HBNM(N,M,J)*rz
	ENDDO
 
      IF (IE .EQ. 'I')  THEN
         IF (N .GT. KINT)  GO TO 500
         LJ = LINT
      ELSE
         IF (N .GT. KEXT)  GO TO 500
         LJ = LEXT
         END IF

      FN(N,M) = FLOAT(N)

      IF (M .GT. 0)  GO TO 300
      DO 301 J=1-IBO-JBO,KT
      IF (IE .EQ. 'I')  THEN
         BINT(N,M,J)   = GNM(N,M,J)
      ELSE
         BEXT(N,M,J)   = GNM(N,M,J)
         END IF
  301 CONTINUE
      GO TO 500
  300 continue
      DO 302 J=1-IBO-JBO,LJ
      IF (IE .EQ. 'I')  THEN
         BINT(N,M,J)   = GNM(N,M,J)
         BINT(M-1,N,J) = HNM(N,M,J)
      ELSE
         BEXT(N,M,J)   = GNM(N,M,J)
         BEXT(M-1,N,J) = HNM(N,M,J)
         END IF
  302 CONTINUE
C
  500 CONTINUE
C     **********************************************************
C     SYNTHESIZES THE VALUE OF B0 FROM THE MODEL	
C     **********************************************************
      CALL SCHNEVPD(RZ,RLAT,FLON,dum,T,L,dum,dum,B)
	  RETURN
9999  STOP
      END
C
C
      SUBROUTINE  SHAB1D (FLAT,FLON,T,RZ,B)
C-------------------------------------------------------------------
C	COMPUTES THE HOURLY VALUES OF B1 FROM A SET OF SH COEFFICIENTS
C	IN A POINT OF A GIVEN GEOCENTRIC LATITUDE AND LONGITUDE
C	OF THE EARTH'S SURFACE FOR A GIVEN MONTH AND A GIVEN SUSPOT NUMER
C
C   PARAMETERS ARE THE SAME AS IN SHAMDB0D, EXCEPT:
C		FLAT	Geographic latitude
C		B		=B1
C
C	***** PARAMS & COEFFS IN DATA SENTENCES *****
C-------------------------------------------------------------------
C
      PARAMETER   (IBO=0,JBO=1,KDIM=6,LDIM=4,L=-1)
      DIMENSION   FN(0:KDIM,0:KDIM), CONST(0:KDIM,0:KDIM)
      DIMENSION   GNM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM),
     *			HNM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM)
	  DIMENSION   GANM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM),
     *			HANM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM),
     *            GBNM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM),
     *			HBNM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM)
      DIMENSION   BINT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM),
     *            BEXT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM)
      CHARACTER*1 IE       
      COMMON  BINT,BEXT,RE,TZERO,IFIT,IB,KINT,LINT,KEXT,
     *              LEXT,KMAX,FN
C      ,CONST

	  DATA ALT /300./

      DATA THETA,RE,    TZERO,IFIT,ICEN,IREF,IB,KINT,LINT,KEXT,LEXT
     *     /180.,6371.2,1.0,  -1,  0,   0,   2, 6,   4,   0,   -1/

  	  DATA ((CONST(N,M), M=0,N), N=0,KDIM)
     *	 /4*1.,1.73205,0.866025,1.,2.44949,1.93649,0.7905691,1.,
     *	  3.16228,3.35410,2.09165,0.739510,1.,3.87298,5.12348,
     *	  4.18330,2.21853,0.701561,1.,4.58258,2*7.24569,4.96078,
     *      2.32681,0.671693/

	  DATA IE /"I"/

      DATA (((GANM(N,M,J),GBNM(N,M,J),HANM(N,M,J),HBNM(N,M,J),
     *    	J=0,LDIM), M=0,N), N=0,KDIM)
     *   /1.156, 0.039,  0.000, 0.000,
     *    1.725,-0.053,  0.000, 0.000,  1.097,-0.032,  0.000, 0.000,
     *   -0.579, 0.019,  0.000, 0.000,  0.265,-0.010,  0.000, 0.000,
     *   -2.895, 0.023,  0.000, 0.000,
     *    3.269,-0.025,  0.000, 0.000,  2.278,-0.015,  0.000, 0.000,
     *   -1.789, 0.009,  0.000, 0.000,  0.653,-0.005,  0.000, 0.000,
     *   -3.240, 0.052, -2.645, 0.030,
     *    4.404,-0.062,  3.283,-0.038,  2.827,-0.038,  2.181,-0.019,
     *   -1.496, 0.020, -1.143, 0.011,  0.688,-0.011,  0.512,-0.008,
     *   -0.023,-0.025,  0.000, 0.000,
     *   -0.370, 0.031,  0.000, 0.000, -0.385, 0.017,  0.000, 0.000,
     *    0.150,-0.009,  0.000, 0.000,  0.019, 0.007,  0.000, 0.000,
     *    1.704, 0.006, -1.766, 0.022,
     *   -2.115,-0.007,  2.309,-0.028, -1.610,-0.003,  1.314,-0.015,
     *    0.806, 0.002, -0.873, 0.010, -0.249,-0.002,  0.445,-0.005,
     *    0.256,-0.009, -2.959, 0.023,
     *   -0.662, 0.013,  3.643,-0.030, -0.208, 0.001,  2.208,-0.015,
     *    0.144,-0.001, -1.326, 0.010, -0.205, 0.005,  0.678,-0.007,
     *    1.730,-0.030,  0.000, 0.000,
     *   -2.072, 0.035,  0.000, 0.000, -1.027, 0.016,  0.000, 0.000,
     *    0.946,-0.008,  0.000, 0.000, -0.644, 0.009,  0.000, 0.000,
     *    3.925,-0.060,  1.613,-0.015,
     *   -4.790, 0.070, -2.021, 0.019, -3.293, 0.048, -1.273, 0.006,
     *    1.829,-0.026,  0.797,-0.005, -0.767, 0.011, -0.395, 0.006,
     *   -1.988, 0.027, -0.761, 0.003,
     *    2.258,-0.031,  0.978,-0.004,  1.772,-0.026,  0.459,-0.003,
     *   -0.813, 0.014, -0.257, 0.004,  0.173,-0.003,  0.223,-0.001,
     * 20*0.000,
     *   -1.356, 0.011,  0.000, 0.000,
     *    0.079,-0.003,  0.000, 0.000,  0.415,-0.012,  0.000, 0.000,
     *   -0.249, 0.004,  0.000, 0.000, -0.087, 0.004,  0.000, 0.000,
     *   -1.155,-0.012,  0.261,-0.026,
     *    1.619, 0.011, -0.217, 0.032,  0.989, 0.009, -0.361, 0.019,
     *   -0.745,-0.001,  0.009,-0.009,  0.347, 0.000,  0.178, 0.005,
     *    4.672,-0.032,  0.562, 0.017,
     *   -5.868, 0.040, -0.850,-0.020, -3.798, 0.026, -0.145,-0.020,
     *    2.079,-0.014,  0.160, 0.008, -0.943, 0.007, -0.417, 0.001,
     * 40*0.000,
     *    2.477, 0.000,  0.000, 0.000,
     *   -1.815,-0.011,  0.000, 0.000, -1.571, 0.002,  0.000, 0.000,
     *    0.551, 0.004,  0.000, 0.000, -0.044,-0.008,  0.000, 0.000,
     *    2.160,-0.010, -0.305, 0.012,
     *   -2.618, 0.010,  0.529,-0.016, -1.782, 0.006,  0.634,-0.007,
     *    0.976,-0.003, -0.449, 0.006, -0.331, 0.001, -0.004,-0.004,
     *   -0.394, 0.002,  0.851,-0.020,
     *    0.359,-0.003, -1.051, 0.024,  0.357, 0.002, -0.239, 0.012,
     *    0.005,-0.001,  0.210,-0.008, -0.028,-0.003, -0.322, 0.005,
     * 60*0.000,
     *   -6.760, 0.064,  0.000, 0.000,
     *    7.700,-0.073,  0.000, 0.000,  5.394,-0.054,  0.000, 0.000,
     *   -2.788, 0.026,  0.000, 0.000,  0.923,-0.007,  0.000, 0.000,
     *   -2.328, 0.024, -0.463, 0.020,
     *    2.923,-0.027,  0.490,-0.025,  1.768,-0.019,  0.711,-0.017,
     *   -1.068, 0.009, -0.363, 0.010,  0.596,-0.004, -0.073,-0.004,
     *   -1.911, 0.016, -4.519, 0.041,
     *    2.644,-0.024,  5.569,-0.050,  1.287,-0.009,  3.707,-0.031,
     *   -0.894, 0.007, -2.121, 0.019,  0.669,-0.007,  0.933,-0.010,
     * 80*0.000/ 

      KMAX = MAX(KINT,KEXT)
      IF (KMAX .GT. KDIM)  GO TO 9999
      KT = MAX(LINT,LEXT)
      IF (KT .GT. LDIM)  GO TO 9999

	DO 500 N=0,KMAX
	DO 500 M=0,N

	DO J=0,KT
	 GNM(N,M,J)=GANM(N,M,J)+GBNM(N,M,J)*rz
	 HNM(N,M,J)=HANM(N,M,J)+HBNM(N,M,J)*rz
	ENDDO
 
      IF (IE .EQ. 'I')  THEN
         IF (N .GT. KINT)  GO TO 500
         LJ = LINT
      ELSE
         IF (N .GT. KEXT)  GO TO 500
         LJ = LEXT
         END IF

      FN(N,M) = FLOAT(N)

      IF (M .GT. 0)  GO TO 300
  255 FORMAT (1X,A1,2I3,F9.4,E15.6,F10.3,4F20.3:/(22X,5F20.3))
      DO 301 J=1-IBO-JBO,KT
      IF (IE .EQ. 'I')  THEN
         BINT(N,M,J)   = GNM(N,M,J)
      ELSE
         BEXT(N,M,J)   = GNM(N,M,J)
         END IF
  301 CONTINUE
      GO TO 500
  300 continue
  260 FORMAT (1X,A1,2I3,F9.4,E15.6,10F10.3:/(32X,10F10.3))
      DO 302 J=1-IBO-JBO,LJ
      IF (IE .EQ. 'I')  THEN
         BINT(N,M,J)   = GNM(N,M,J)
         BINT(M-1,N,J) = HNM(N,M,J)
      ELSE
         BEXT(N,M,J)   = GNM(N,M,J)
         BEXT(M-1,N,J) = HNM(N,M,J)
         END IF
  302 CONTINUE

  500 CONTINUE
C
C     **********************************************************
C     SYNTHESIZES THE VALUE OF B1 FROM THE MODEL	
C     **********************************************************
      CALL SCHNEVPD(RZ,FLAT,FLON,dum,T,L,dum,dum,B)
C
      RETURN
 9999	STOP
      END
C
C
      SUBROUTINE SCHNEVPD (RZ,FLAT,FLON,R,T,L,BN,BE,BV)
C-------------------------------------------------------------------
C     WHEN L IS POSITIVE:
C     COMPUTES SPHERICAL CAP HARMONIC (GEOCENTRIC) FIELD COMPONENTS
C     HORIZONTAL NORTH BN,HORIZONTAL EAST BE,AND VERTICAL DOWNWARD BV.
C     WHEN L IS NEGATIVE:
C     COMPUTES GENERAL FUNCTION BV, ITS HORIZONTAL NORTH DERIVATIVE BN,
C     AND ITS HORIZONTAL EAST DERIVATIVE BE, ON SPHERICAL CAP SURFACE.
C     NOTE THAT THESE ARE METRICAL DERIVATIVES, AND BE IS THE
C     LONGITUDINAL DERIVATIVE DIVIDED BY SIN(COLATITUDE).

C     FLAT,FLON,R ARE GEOCENTRIC SPHERICAL CAP LATITUDE,LONGITUDE,RADIAL
C     DISTANCE; T IS TIME.

C     L =  0  ON FIRST CALL:  RETURNS SPHERICAL CAP POLE POSITION FLATO,FLONO
C             AND HALF-ANGLE THETA AS BN,BE, AND BV AFTER INITIALIZATION.
C             ON SUBSEQUENT CALLS:  ACTS AS L=1.
C          1  COMPUTES POTENTIAL FIELD COMPONENTS FROM INTERNAL COEFFICIENTS.
C          2  COMPUTES POTENTIAL FIELD COMPONENTS FROM EXTERNAL COEFFICIENTS.
C          3  COMPUTES FIELD FROM BOTH INTERNAL AND EXTERNAL COEFFICIENTS.
C         -1  COMPUTES GENERAL FUNCTION BV AND DERIVATIVES BN WITH RESPECT TO
C             LATITUDE AND BE WITH RESPECT TO LONGITUDE DIVIDED BY COS(LAT)
C             (R IS DUMMY VARIABLE IN THIS CASE).
C     NOTE:   SUBROUTINE IS INITIALIZED DURING FIRST CALL REGARDLESS OF L.

C     SUBPROGRAM USED:  LEGFUN

C	***** PARAMS & COEFFS TRANSFERRED FROM MAIN PROGRAM *****

C	ADAPTED FROM SUBROUTINE SCHNEV OF G.V. HAINES (COMPUTERS & GEOSCIENCES, 
C      14, 413-447, 1988)
C-------------------------------------------------------------------

      PARAMETER   (IBO=0,JBO=1,KDIM=6,LDIM=4)                                     
      DIMENSION   FN(0:KDIM,0:KDIM), CONST(0:KDIM,0:KDIM)
      DIMENSION   CML(KDIM), SML(KDIM)
      DIMENSION   DELT(0:LDIM)
      DIMENSION   BINT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM),
     *            BEXT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM)
      COMMON      BINT,BEXT,RE,TZERO,IFIT,IB,KINT,LINT,KEXT,
     *              LEXT,KMAX,FN
C     ,CONST
      CHARACTER*1 IE,RESP
C
      DATA ((CONST(N,M), M=0,N), N=0,KDIM)
     *	 /4*1.,1.73205,0.866025,1.,2.44949,1.93649,0.7905691,1.,
     *	  3.16228,3.35410,2.09165,0.739510,1.,3.87298,5.12348,
     *	  4.18330,2.21853,0.701561,1.,4.58258,2*7.24569,4.96078,
     *      2.32681,0.671693/

        dfarg=(atan(1.0)*4.)/180.

C     IBF   =  0   TO USE ORDINARY POLYNOMIALS AS BASIS FUNCTIONS
C              1          LEGENDRE POLYNOMIALS
C              2          FOURIER SERIES
C              3          COSINE SERIES
C              4          SINE SERIES
C     NOTE:    TZERO AND THINT MAY DEPEND ON IBF.
      IBF   =  2                                                       
      T1=1.
      T2=12.
      CALL TBFIT (T1,T2,IBF,THINT,TZERO)                                

C      IF (L .NE. 0)  GO TO 100
C      BN = FLATO
C      BE = FLONO
C      BV = THETA
C      RETURN

  100 IF (L .GE. 0)  THEN
         IF (IFIT .LT. 0)  GO TO 999
         AOR = RE/R
         AR = AOR**2
         IF (L .GT. 1)  GO TO 107
      ELSE
         IF (IFIT .GE. 0)  GO TO 999
         AR = -1.
         END IF
      KT = LINT
      GO TO 109
  107 IF (KEXT .GT. 0)  AOR3 = AOR*AR
      IF (L .GT. 2)  GO TO 108
      KT = LEXT
      GO TO 109
  108 KT = MAX (LINT,LEXT)
  109 DELT(0) = 1.
      IF (KT .LE. 0)  GO TO 103
      DEL = (T - TZERO)/THINT
      DO 102 I=1,KT
      IF (I .EQ. 1)  THEN
         IF (IBF .LE. 1) THEN
             DELT(I) = DEL
             ELSE IF (IBF .EQ. 2)  THEN
             ST = SIN(DEL)
             DELT(I) = ST
             ELSE IF (IBF .EQ. 3)  THEN
             DELT(I) = COS(DEL)
             ELSE
             DELT(I) = SIN(DEL)
             ENDIF
         GO TO 102
         ENDIF
      IF (IBF .EQ. 0)  THEN
          DELT(I) = DELT(I-1)*DEL
      ELSE IF (IBF .EQ. 1)  THEN
          RECIP = 1./FLOAT(I)
          DELT(I) = (2.-RECIP)*DELT(I-1)*DEL - (1.-RECIP)*DELT(I-2)
      ELSE IF (IBF .EQ. 2)  THEN
           IF ((I/2)*2 .EQ. I)  THEN
             IF (I .EQ. 2)  THEN
                CT = COS(DEL)
                DELT(I) = CT
                ELSE
                DELT(I) = DELT(I-2)*CT - DELT(I-3)*ST
                ENDIF
             ELSE
             DELT(I) = DELT(I-2)*CT + DELT(I-1)*ST
             ENDIF
      ELSE IF (IBF .EQ. 3)  THEN
          DELT(I) = COS(I*DEL)
      ELSE IF (IBF .EQ. 4)  THEN
          DELT(I) = SIN(I*DEL)
      ELSE
          GO TO 999
      ENDIF
  102 CONTINUE
      incept = 0                                                              
      if ((ibf.eq.2 .or. ibf.eq.3) .and. incept .eq. 1)  then
c     change to intercept form of fourier series.
          do i=2,lint,4-ibf
          delt(i) = 1. - delt(i)
          enddo
          endif
  103 X = 0.
      Y = 0.
      Z = 0.
      IF (L .EQ. 2)  GO TO 106
      IF (KINT .LT. 0)  GO TO 106
      GTI = 0.
      DO 105 I=1-IBO-JBO,LINT
  105 GTI = GTI + BINT(0,0,I)*DELT(I)
      Z = -AR*GTI
      N =  0
  106 COLAT = 90. - FLAT
      DO 150 N=1,KMAX
      IF (N .GT. 1)  GO TO 115
      CL = COS(FLON*dfarg)
      SL = SIN(FLON*dfarg)
      CML(1) = CL
      SML(1) = SL
      GO TO 120
  115 SML(N) = SL*CML(N-1) + CL*SML(N-1)
      CML(N) = CL*CML(N-1) - SL*SML(N-1)
  120 CONTINUE
      DO 150 M=0,N
      IF (IB .EQ. 2)  GO TO 121
      NMM = N - M
      IF ((NMM/2)*2 .NE. NMM)  GO TO 150
  121 FFN = FN(N,M)
      CALL LEGFUN (M,FFN,CONST(N,M),COLAT,P,DP,PMS,0)
      IF (L .GE. 0)  THEN
         AR = AOR**(FFN+2.)
      ELSE
         AR = 1.
         FFN = -2.
         DP = -DP
         PMS = -PMS
         END IF
      IF (M .NE. 0)  GO TO 130
      BT1 = 0.
      BT3 = 0.
      BT  = 0.
      IF (L .EQ. 2)  GO TO 123
      IF (N .GT. KINT)  GO TO 123
      GTI = 0.
      DO 122 I=1-IBO-JBO,LINT
  122 GTI  = GTI  + BINT(N,M,I)*DELT(I)
      BT1  = AR*GTI
      BT3  = BT1
  123 IF (L .LE. 1)  GO TO 125
      IF (N .GT. KEXT)  GO TO 125
      GTE = 0.
      DO 124 I=1-IBO-JBO,LEXT
  124 GTE = GTE + BEXT(N,M,I)*DELT(I)
      BT  = AOR3/AR*GTE
      BT1 = BT1 + BT
  125 X = X + BT1*DP
      Z = Z - (FFN*(BT3-BT)+BT3)*P
      GO TO 150
  130 BT1 = 0.
      BT2 = 0.
      BT3 = 0.
      BT  = 0.
      IF (L .EQ. 2)  GO TO 133
      IF (N .GT. KINT)  GO TO 133
      GTI = 0.
      HTI = 0.
      DO 132 I=1-IBO-JBO,LINT
      GTI = GTI + BINT(N,M,I)*DELT(I)
  132 HTI = HTI + BINT(M-1,N,I)*DELT(I)
      BT1 = AR*(GTI*CML(M) + HTI*SML(M))
      BT2 = AR*(GTI*SML(M) - HTI*CML(M))
      BT3 = BT1
  133 IF (L .LE. 1)  GO TO 135
      IF (N .GT. KEXT)  GO TO 135
      GTE = 0.
      HTE = 0.
      DO 134 I=1-IBO-JBO,LEXT
      GTE = GTE + BEXT(N,M,I)*DELT(I)
  134 HTE = HTE + BEXT(M-1,N,I)*DELT(I)
      RA = AOR3/AR
      BT = RA*(GTE*CML(M) + HTE*SML(M))
      BT1 = BT1 + BT
      BT2 = BT2 + RA*(GTE*SML(M) - HTE*CML(M))
  135 X = X + BT1*DP
      Y = Y + BT2*PMS
      Z = Z - (FFN*(BT3-BT)+BT3)*P
  150 CONTINUE
      BN = X
      BE = Y
      BV = Z
      RETURN
  999 STOP
      END
C
C
      SUBROUTINE TBFIT (T1,T2,IBF,THINT,TZERO)
C-------------------------------------------------------------------
C	COURTESY OF G.V. HAINES
C
C     T2    =  BEGINNING OF TIME INTERVAL.
C     T1    =  END OF TIME INTERVAL.
C     IBF   =  0   TO USE ORDINARY POLYNOMIALS AS TEMPORAL BASIS FUNCTIONS
C              1          LEGENDRE POLYNOMIALS
C              2          FOURIER SERIES
C              3          COSINE SERIES
C              4          SINE SERIES
C              5          COSINE + SINE SERIES
C     TZERO =  TIME-TRANSLATION PARAMETER:
C              FOR IBF.LE.1, CHOOSE TZERO = CENTER OF TIME INTERVAL
C              FOR IBF.GE.2, CHOOSE TZERO = BEGINNING OF TIME INTERVAL.
C     THINT =  TIME-SCALING PARAMETER. THINT = HALF OF TIME INTERVAL T2-T1
C              FOR IBF.LE.1; PI*HALF OF TIME INTERVAL FOR IBF.EQ.2;
C              AND PI*TIME INTERVAL FOR IBF.GE.3.
C     NOTE:    CHOOSING TZERO AND THINT IN THIS WAY SCALES TIME
C              TO (-1,1) FOR IBF.LE.1;  TO (0,2PI) FOR IBF.EQ.2;
C              AND TO (0,PI) FOR IBF.GE.3.
C-------------------------------------------------------------------

      IBFI  = IBF
      IF (IBFI .LE. 1)  THEN
          TZERO = (T2+T1)/2.D0
         ELSE
          TZERO =  T1
         ENDIF
      THINT = T2 - T1
      IF (IBFI .LE. 2)  THINT = THINT/2.D0
C      IF (IBFI .EQ. 4)  THEN
C          DELT(0) = 0.D0
C         ELSE
C          DELT(0) = 1.D0
C         ENDIF
      RETURN
      END
C
C
      SUBROUTINE LEGFUN (M,FN,CONST,COLAT,P,DP,PMS,IPRT)
C-------------------------------------------------------------------
C     SERIES FORM FOR ASSOCIATED LEGENDRE FUNCTION P, ITS DERIVATIVE DP,
C     AND THE FUNCTION PMS=P*M/SIN(COLAT), IN POWERS OF (1-COS(COLAT))/2.
C     INTEGRAL ORDER M, REAL DEGREE FN, NORMALIZING CONSTANT CONST.
C     COLATITUDE COLAT IN DEGREES.
C     IPRT = 0     NO PRINT-OUT
C            1     PRINT PARAMETERS AND P SERIES
C            2     PRINT PARAMETERS AND DP SERIES
C            3     PRINT PARAMETERS AND BOTH P AND DP SERIES
C           -1     PRINT PARAMETERS ONLY
C     INPUT M,FN,CONST,COLAT,IPRT.   OUTPUT P,DP,PMS
C	ADAPTED FROM G.V. HAINES (COMPUTERS & GEOSCIENCES, 14, 413-447, 1988).
C-------------------------------------------------------------------
      REAL*8  FNN,AL,A,B,PNM,DPNM
      DIMENSION  AM(60), BM(60)

      DATA   JMAX/60/

      dfarg=(atan(1.0)*4.)/180.
      FNN = FN*(FN+1.)
      IF (COLAT .LT. 60.)  THEN
          X = SIN(dfarg*COLAT/2.)**2
          C = 1. - 2.*X
      ELSE
          C = COS(COLAT*dfarg)
          X = (1. - C)/2.
          END IF
      S = SIN(COLAT*dfarg)
      IF (M .GT.1)  GO TO 20
      IF (M .LT. 0)  STOP
      AL = CONST
      GO TO 50
   20 AL = CONST*S**(M-1)
   50 PNM = AL
      DPNM = 0.
      J = 0
  100 J = J + 1
      JPM = J + M
      B = AL*((JPM-1)-FNN/JPM)
      DPNM = DPNM + B
      A = (B*X)/J
      PNM = PNM + A
      AL = A
C     STORE P OR DP SERIES FOR PRINTOUT.
      IF (IPRT .LE. 0)  GO TO 150
      IF (IPRT .EQ. 2)  GO TO 145
      AM(J) = A
      IF (IPRT .EQ. 1)  GO TO 150
  145 BM(J) = B
C     CHECK FOR TERMINATION OF SERIES.
  150 ABSA = ABS(A)
      ABSB = ABS(B)
      IF (ABSB .GE. 1.E-7)  GO TO 160
      IF (ABSA .LT. 1.E-7)  GO TO 110
  160 IF (ABSB .GE. 1.E+13)  GO TO 105
      IF (ABSA .GE. 1.E+13)  GO TO 105
C     CHANGE CHECK LIMITS ACCORDING TO ACCURACY DESIRED AND ACCORDING
C     TO WORD SIZE OF COMPUTER.
C     FOR 32-BIT WORD, DOUBLE PRECISION, E-8 AND E+8 GIVE 7 DIGITS ACCURACY.
C     FOR 60-BIT WORD, DOUBLE PRECISION, E-15 AND E+15 GIVE 14 DIGITS ACCURACY.
C     FOR 60-BIT WORD, SINGLE PRECISION, E-8 AND E+7 GIVE 7 DIGITS ACCURACY.
C     (DOUBLE OR SINGLE PRECISION REFER TO FNN,AL,A,B,PNM,DPNM)
      IF (J .LT. JMAX)  GO TO 100
C     CONVERGENCE SLOW OR JMAX TOO SMALL
  105 CONTINUE
C     NUMERICAL ERROR UNACCEPTABLY LARGE DUE TO ADDING OF
C     LARGE AND SMALL NUMBERS.
      PRINT*, M,FN,CONST,J,A,B
  108 FORMAT (//12H ** ERROR **/1X,I5,F10.5,E15.7,I5,2D15.7)
      STOP
C     SERIES TRUNCATED SUCCESSFULLY.
  110 PS = PNM
      DPS = DPNM
      IF (M .NE. 0)  GO TO 115
      PMS = 0.
      P = PS
      DP = DPS*S/2.
      GO TO 120
  115 PMS = PS*M
      P = PS*S
      DP = DPS*S*S/2. + C*PMS
  120 CONTINUE
C     PRINT TERMS OF SERIES
      IF (IPRT .EQ. 0)  RETURN
      PRINT *,  M,FN,CONST,COLAT,P,DP,PMS,J
  125 FORMAT (/1X,I5,F10.5,E20.12,F10.2,3F25.14,I5)
      IF (IPRT .LT. 0)  RETURN
      IF (IPRT .EQ. 2)  GO TO 135
      PRINT *, (AM(I),I=1,J)
  130 FORMAT (1X,16E8.1)
      IF (IPRT .EQ. 1)  RETURN
  135 CONTINUE
C  135 PRINT *, (BM(I),I=1,J)
      RETURN
      END
C      
C      
        REAL FUNCTION B0_98 ( HOUR, SAX, SUX, NSEASN, R, ZLO, ZMODIP)
C-----------------------------------------------------------------
C Interpolation procedure for bottomside thickness parameter B0.
C Array B0F(ILT,ISEASON,IR,ILATI) distinguishes between day and
C night (ILT=1,2), four seasons (ISEASON is northern season with
C ISEASON=1 northern spring), low and high solar activity Rz12=10,
C 100 (IR=1,2), and modified dip latitudes of 0, 18 and 45
C degress (ILATI=1,2,3). In the DATA statement the first value
C corresponds to B0F(1,1,1,1), the second to B0F(2,1,1,1), the
C third to B0F(1,2,1,1) and so on.
C
C input:
C       hour    LT in decimal hours
C       SAX     time of sunrise in decimal hours
C       SUX     time of sunset in decimal hours
C       nseasn  season in northern hemisphere (1=spring)
C       R       12-month running mean of sunspot number
C       ZLO     longitude
C       ZMODIP  modified dip latitude
C
C JUNE 1989 --------------------------------------- Dieter Bilitza
C
C Updates (B0_new -> B0_98):
C
C 01/98 corrected to include a smooth transition at the modip equator
C       and no discontinuity at the equatorial change in season.
C 09/98 new B0 values incl values at the magnetic equator
C 10/98 longitude as input to determine if magnetic equator in northern 
C         or southern hemisphere
C-------------------------------------------------------------------
      REAL      NITVAL
      DIMENSION B0F(2,4,2,3),bfr(2,2,3),bfd(2,3),zx(5),g(6),dd(5)
      DATA      B0F/201,68,210,61,192,68,199,67,240,80,245,83,
     &              233,71,230,65,108,65,142,81,110,68,77,75,
     &              124,98,164,100,120,94,96,112,78,81,94,84,
     &              81,81,65,70,102,87,127,91,109,88,81,78/
        data    zx/45.,72.,90.,108.,135./,dd/5*3.0/

        num_lat=3

C jseasn is southern hemisphere season
        jseasn=nseasn+2
        if(jseasn.gt.4) jseasn=jseasn-4

        zz = zmodip + 90.
        zz0 = 0.

C Interpolation in Rz12: linear from 10 to 100
        DO 7035 ISL=1,num_lat
          DO 7034 ISD=1,2
            bfr(isd,1,isl) = b0f(isd,nseasn,1,isl) +
     &      (b0f(isd,nseasn,2,isl) - b0f(isd,nseasn,1,isl))/90.*(R-10.)
            bfr(isd,2,isl) = b0f(isd,jseasn,1,isl) +
     &      (b0f(isd,jseasn,2,isl) - b0f(isd,jseasn,1,isl))/90.*(R-10.)
7034      continue
C Interpolation day/night with transitions at SAX (sunrise)
C and SUX (sunset) for northern/southern hemisphere iss=1/2
          do 7033 iss=1,2
                DAYVAL = BFR(1,ISS,ISL)
                NITVAL = BFR(2,ISS,ISL)
                BFD(iss,ISL) = HPOL(HOUR,DAYVAL,NITVAL,SAX,SUX,1.,1.)
7033      continue
7035    continue

C Interpolation with epstein-transitions in modified dip latitude.
C Transitions at +/-18 and +/-45 degrees; constant above +/-45.
C
C g(1:5) are the latitudinal slopes of B0;
C       g(1) is for the region from -90 to -45 degrees
C       g(2) is for the region from -45 to -18 degrees
C       g(3) is for the region from -18 to   0 degrees
C       g(4) is for the region from   0 to  18 degrees
C       g(5) is for the region from  18 to  45 degrees
C       g(6) is for the region from  45 to  90 degrees
C
C B0 =  bfd(2,3) at modip = -45,
C       bfd(2,2) at modip = -18,
C       bfd(2,1) or bfd(1,1) at modip = 0,
C       bfd(1,2) at modip = 20,
C       bfd(1,3) at modip = 45.
C If the Longitude is between 200 and 320 degrees then the modip 
C equator is in the southern hemisphere and bfd(2,1) is used at the 
C equator, otherwise bfd(1,1) is used.
c
        zx1=bfd(2,3)
        zx2=bfd(2,2)
        zx3=bfd(1,1)
        if(zlo.gt.200.0.and.zlo.lt.320) zx3=bfd(2,1)
        zx4=bfd(1,2)
        zx5=bfd(1,3)
        g(1) = 0.
        g(2) = ( zx2 - zx1 ) / 27.
        g(3) = ( zx3 - zx2 ) / 18.
        g(4) = ( zx4 - zx3 ) / 18.
        g(5) = ( zx5 - zx4 ) / 27.
        g(6) = 0.

c        bb0 = bfd(2,3)
c      SUM = bb0
        sum=zx1
      DO 1 I=1,5
        aa = eptr(zz ,dd(i),zx(i))
        bb = eptr(zz0,dd(i),zx(i))
        DSUM = (G(I+1) - G(I)) * (AA-BB) * dd(i)
        SUM = SUM + DSUM
1       continue
      B0_98 = SUM

        RETURN
        END
C
C
      SUBROUTINE TAL(SHABR,SDELTA,SHBR,SDTDH0,AUS6,SPT)                         
C CALCULATES THE COEFFICIENTS SPT FOR THE POLYNOMIAL
C Y(X)=1+SPT(1)*X**2+SPT(2)*X**3+SPT(3)*X**4+SPT(4)*X**5               
C TO FIT THE VALLEY IN Y, REPRESENTED BY:                
C Y(X=0)=1, THE X VALUE OF THE DEEPEST VALLEY POINT (SHABR),                    
C THE PRECENTAGE DEPTH (SDELTA), THE WIDTH (SHBR) AND THE                       
C DERIVATIVE DY/DX AT THE UPPER VALLEY BOUNDRY (SDTDH0).                        
C IF THERE IS AN UNWANTED ADDITIONAL EXTREMUM IN THE VALLEY                     
C REGION, THEN AUS6=.TRUE., ELSE AUS6=.FALSE..     
C FOR -SDELTA THE COEFF. ARE CALCULATED FOR THE FUNCTION                        
C Y(X)=EXP(SPT(1)*X**2+...+SPT(4)*X**5).           
      DIMENSION SPT(4)                             
      LOGICAL AUS6    
      Z1=-SDELTA/(100.0*SHABR*SHABR)               
      IF(SDELTA.GT.0.) GOTO 500                    
      SDELTA=-SDELTA  
      Z1=ALOG(1.-SDELTA/100.)/(SHABR*SHABR)        
500   Z3=SDTDH0/(2.*SHBR)                          
      Z4=SHABR-SHBR   
      SPT(4)=2.0*(Z1*(SHBR-2.0*SHABR)*SHBR+Z3*Z4*SHABR)/                        
     &  (SHABR*SHBR*Z4*Z4*Z4)                        
      SPT(3)=Z1*(2.0*SHBR-3.0*SHABR)/(SHABR*Z4*Z4)-
     &  (2.*SHABR+SHBR)*SPT(4)          
      SPT(2)=-2.0*Z1/SHABR-2.0*SHABR*SPT(3)-3.0*SHABR*SHABR*SPT(4)              
      SPT(1)=Z1-SHABR*(SPT(2)+SHABR*(SPT(3)+SHABR*SPT(4)))                      
      AUS6=.FALSE.    
      B=4.*SPT(3)/(5.*SPT(4))+SHABR                
      C=-2.*SPT(1)/(5*SPT(4)*SHABR)                
      Z2=B*B/4.-C     
      IF(Z2.LT.0.0) GOTO 300                       
      Z3=SQRT(Z2)     
      Z1=B/2.         
      Z2=-Z1+Z3       
      IF(Z2.GT.0.0.AND.Z2.LT.SHBR) AUS6=.TRUE.     
      IF (ABS(Z3).GT.1.E-15) GOTO 400              
      Z2=C/Z2         
      IF(Z2.GT.0.0.AND.Z2.LT.SHBR) AUS6=.TRUE.     
      RETURN          
400   Z2=-Z1-Z3       
      IF(Z2.GT.0.0.AND.Z2.LT.SHBR) AUS6=.TRUE.     
300   RETURN          
      END             
C
C
        SUBROUTINE VALGUL(XHI,HVB,VWU,VWA,VDP)
C --------------------------------------------------------------------- 
C   CALCULATES E-F VALLEY PARAMETERS; T.L. GULYAEVA, ADVANCES IN
C   SPACE RESEARCH 7, #6, 39-48, 1987.
C
C       INPUT:  XHI     SOLAR ZENITH ANGLE [DEGREE]
C       
C       OUTPUT: VDP     VALLEY DEPTH  (NVB/NME)
C               VWU     VALLEY WIDTH  [KM]
C               VWA     VALLEY WIDTH  (SMALLER, CORRECTED BY RAWER)
C               HVB     HEIGHT OF VALLEY BASE [KM]
C -----------------------------------------------------------------------
C
        COMMON  /CONST/UMR
C
        CS = 0.1 + COS(UMR*XHI)
        ABC = ABS(CS)
        VDP = 0.45 * CS / (0.1 + ABC ) + 0.55
        ARL = ( 0.1 + ABC + CS ) / ( 0.1 + ABC - CS)
        ZZZ = ALOG( ARL )
        VWU = 45. - 10. * ZZZ
        VWA = 45. -  5. * ZZZ
        HVB = 1000. / ( 7.024 + 0.224 * CS + 0.966 * ABC )
        RETURN
        END
C
C
      Subroutine DRegion(z,it,f,vKp,f5SW,f6WA,elg)
c-----------------------------------------------------------------------
c Reference: Danilov, Rodevich, and Smirnova, Adv. Space Res.  
C     15, #2, 165, 1995.
C
C Input:     z    - solar zenith angle in degrees
C            it   - season (month)
C            f    - F10.7 solar radio flux (daily)
C            vKp  - Kp magnetic index (3-hour)
C            f5SW - indicator for Stratospheric Warming (SW) conditions
C                   =0 no SW, =0.5 minor SW, =1 major SW
C            f6WA - indicator for Winter Anomaly (WA) conditions
C                   =0 no WA, =0.5 weak WA, =1 strong WA
C Criteria for SW and WA indicators:
C      SW minor:  Temperature increase at the 30 hPa level by 10 deg.
C      SA major:  The same but by 20 degrees.
C         Temperature data for each year are published  
C         in Beilage zur Berliner Wetterkarte (K. Labitzke et al.).
C      WA weak:   An increase of the absorption in the 2-2.8 MHz  
C                 range at short A3 paths by 15 dB
C      WA strong: The same by 30 dB.
C 
C       Only for month 12 to 2 (winter).
C
C Output:      elg(7)  alog10 of electron density [cm-3] at h=60,65,
C                  70,75,80,85, and 90km
c-----------------------------------------------------------------------
c            
cor   dimension h(7),A0(7),A1(7),A2(7),A3(7),A4(7),A5(7),A6(7),elg(7)
      dimension A0(7),A1(7),A2(7),A3(7),A4(7),A5(7),A6(7),elg(7)
      data A0/1.0,1.2,1.4,1.5,1.6,1.7,3.0/
      data A1/0.6,0.8,1.1,1.2,1.3,1.4,1.0/
      data A2/0.,0.,0.08,0.12,0.05,0.2,0./
      data A3/0.,0.,0.,0.,0.,0.,1./
      data A4/0.,0.,-0.30,0.10,0.20,0.30,0.15/
      data A5/0.,-0.10,-0.20,-0.25,-0.30,-.30,0./
      data A6/0.,0.1,0.3,0.6,1.,1.,0.7/
        pi=3.14159265
         if(z.le.45) then
           f1z=1.
         else
           if(z.lt.90) then
             f1z=1.1892*(cos(z*pi/180))**0.5
           else
             f1z=0.
           endif
         endif
         f4S=1.
       if((it.ge.5).and.(it.le.9))then
         f4S=0.
         f5SW=0
         f6WA=0
       endif
       if((it.eq.3).or.(it.eq.4).or.(it.eq.10).or.(it.eq.11))then
         f4S=0.5
         f5SW=0
         f6WA=0
       endif
         f2Kp=vKp
         if(vKp.gt.2) f2Kp=2.
         f3F=(f-60.)/300.*f1z
         do 1 i=1,7
         elg(i)=A0(i)+A1(i)*f1z+A2(i)*f2Kp+A3(i)*f3F+A4(i)*f4S
     *         +A5(i)*f5SW+A6(i)*f6WA
   1     continue
         end
C
C
C
C                     
C************************************************************                   
C*************** EARTH MAGNETIC FIELD ***********************                   
C**************************************************************                 
C
C
      SUBROUTINE FIELDG(DLAT,DLONG,ALT,X,Y,Z,F,DIP,DEC,SMODIP)                  
C THIS IS A SPECIAL VERSION OF THE POGO 68/10 MAGNETIC FIELD                    
C LEGENDRE MODEL. TRANSFORMATION COEFF. G(144) VALID FOR 1973.                  
C INPUT: DLAT, DLONG=GEOGRAPHIC COORDINATES/DEG.(-90/90,0/360),                 
C        ALT=ALTITUDE/KM.                          
C OUTPUT: F TOTAL FIELD (GAUSS), Z DOWNWARD VERTICAL COMPONENT                  
C        X,Y COMPONENTS IN THE EQUATORIAL PLANE (X TO ZERO LONGITUDE).          
C        DIP INCLINATION ANGLE(DEGREE). SMODIP RAWER'S MODFIED DIP.             
C SHEIK,1977.         
      DIMENSION H(144),XI(3),G(144),FEL1(72),FEL2(72)
      COMMON/CONST/UMR                           
      DATA FEL1/0.0, 0.1506723,0.0101742, -0.0286519, 0.0092606,                
     & -0.0130846, 0.0089594, -0.0136808,-0.0001508, -0.0093977,                
     & 0.0130650, 0.0020520, -0.0121956, -0.0023451, -0.0208555,                
     & 0.0068416,-0.0142659, -0.0093322, -0.0021364, -0.0078910,                
     & 0.0045586,  0.0128904, -0.0002951, -0.0237245,0.0289493,                 
     & 0.0074605, -0.0105741, -0.0005116, -0.0105732, -0.0058542,               
     &0.0033268, 0.0078164,0.0211234, 0.0099309, 0.0362792,                     
     &-0.0201070,-0.0046350,-0.0058722,0.0011147,-0.0013949,                    
     & -0.0108838,  0.0322263, -0.0147390,  0.0031247, 0.0111986,               
     & -0.0109394,0.0058112,  0.2739046, -0.0155682, -0.0253272,                
     &  0.0163782, 0.0205730,  0.0022081, 0.0112749,-0.0098427,                 
     & 0.0072705, 0.0195189, -0.0081132, -0.0071889, -0.0579970,                
     & -0.0856642, 0.1884260,-0.7391512, 0.1210288, -0.0241888,                 
     & -0.0052464, -0.0096312, -0.0044834, 0.0201764,  0.0258343,               
     &0.0083033,  0.0077187/                       
      DATA FEL2/0.0586055,0.0102236,-0.0396107,    
     & -0.0167860, -0.2019911, -0.5810815,0.0379916,  3.7508268,                
     & 1.8133030, -0.0564250, -0.0557352, 0.1335347, -0.0142641,                
     & -0.1024618,0.0970994, -0.0751830,-0.1274948, 0.0402073,                  
     &  0.0386290, 0.1883088,  0.1838960, -0.7848989,0.7591817,                 
     & -0.9302389,-0.8560960, 0.6633250, -4.6363869, -13.2599277,               
     & 0.1002136,  0.0855714,-0.0991981, -0.0765378,-0.0455264,                 
     &  0.1169326, -0.2604067, 0.1800076, -0.2223685, -0.6347679,               
     &0.5334222, -0.3459502,-0.1573697,  0.8589464, 1.7815990,                  
     &-6.3347645, -3.1513653, -9.9927750,13.3327637, -35.4897308,               
     &37.3466339, -0.5257398,  0.0571474, -0.5421217,  0.2404770,               
     & -0.1747774,-0.3433644, 0.4829708,0.3935944, 0.4885033,                   
     &  0.8488121, -0.7640999, -1.8884945, 3.2930784,-7.3497229,                
     & 0.1672821,-0.2306652, 10.5782146, 12.6031065, 8.6579742,                 
     & 215.5209961, -27.1419220,22.3405762,1108.6394043/                        
      K=0             
      DO 10 I=1,72    
      K=K+1           
      G(K)=FEL1(I)    
10    G(72+K)=FEL2(I)                              
      RLAT=DLAT*UMR   
      CT=SIN(RLAT)    
      ST=COS(RLAT)    
      NMAX=11         
      D=SQRT(40680925.0-272336.0*CT*CT)            
      RLONG=DLONG*UMR                              
      CP=COS(RLONG)   
      SP=SIN(RLONG)   
      ZZZ=(ALT+40408589.0/D)*CT/6371.2             
      RHO=(ALT+40680925.0/D)*ST/6371.2             
      XXX=RHO*CP      
      YYY=RHO*SP      
      RQ=1.0/(XXX*XXX+YYY*YYY+ZZZ*ZZZ)             
      XI(1)=XXX*RQ    
      XI(2)=YYY*RQ    
      XI(3)=ZZZ*RQ    
      IHMAX=NMAX*NMAX+1                            
      LAST=IHMAX+NMAX+NMAX                         
      IMAX=NMAX+NMAX-1                             
      DO 100 I=IHMAX,LAST                          
100   H(I)=G(I)       
      DO 200 K=1,3,2  
      I=IMAX          
      IH=IHMAX        
300   IL=IH-I         
      F1=2./(I-K+2.)  
      X1=XI(1)*F1     
      Y1=XI(2)*F1     
      Z1=XI(3)*(F1+F1)                             
      I=I-2           
      IF((I-1).LT.0) GOTO 400                      
      IF((I-1).EQ.0) GOTO 500                      
      DO 600 M=3,I,2  
      H(IL+M+1)=G(IL+M+1)+Z1*H(IH+M+1)+X1*(H(IH+M+3)-H(IH+M-1))-                
     &Y1*(H(IH+M+2)+H(IH+M-2))                     
      H(IL+M)=G(IL+M)+Z1*H(IH+M)+X1*(H(IH+M+2)-H(IH+M-2))+                      
     &Y1*(H(IH+M+3)+H(IH+M-1))                     
600   CONTINUE        
500   H(IL+2)=G(IL+2)+Z1*H(IH+2)+X1*H(IH+4)-Y1*(H(IH+3)+H(IH))                  
      H(IL+1)=G(IL+1)+Z1*H(IH+1)+Y1*H(IH+4)+X1*(H(IH+3)-H(IH))                  
400   H(IL)=G(IL)+Z1*H(IH)+2.0*(X1*H(IH+1)+Y1*H(IH+2))                          
700   IH=IL           
      IF(I.GE.K) GOTO 300                          
200   CONTINUE        
      S=0.5*H(1)+2.0*(H(2)*XI(3)+H(3)*XI(1)+H(4)*XI(2))                         
      XT=(RQ+RQ)*SQRT(RQ)                          
      X=XT*(H(3)-S*XXX)                            
      Y=XT*(H(4)-S*YYY)                            
      Z=XT*(H(2)-S*ZZZ)                            
      F=SQRT(X*X+Y*Y+Z*Z)                          
      BRH0=Y*SP+X*CP  
      Y=Y*CP-X*SP     
      X=Z*ST-BRH0*CT  
      Z=-Z*CT-BRH0*ST 
        zdivf=z/f
        IF(ABS(zdivf).GT.1.) zdivf=SIGN(1.,zdivf)
      DIP=ASIN(zdivf)
        ydivs=y/sqrt(x*x+y*y)  
        IF(ABS(ydivs).GT.1.) ydivs=SIGN(1.,ydivs)
      DEC=ASIN(ydivs)
        dipdiv=DIP/SQRT(DIP*DIP+ST)
        IF(ABS(dipdiv).GT.1.) dipdiv=SIGN(1.,dipdiv)
      SMODIP=ASIN(dipdiv)
      DIP=DIP/UMR     
      DEC=DEC/UMR     
      SMODIP=SMODIP/UMR                            
      RETURN          
      END             
C
C
C************************************************************                   
C*********** INTERPOLATION AND REST ***************************                 
C**************************************************************                 
C
C
      SUBROUTINE REGFA1(X11,X22,FX11,FX22,EPS,FW,F,SCHALT,X) 
C REGULA-FALSI-PROCEDURE TO FIND X WITH F(X)-FW=0. X1,X2 ARE THE                
C STARTING VALUES. THE COMUTATION ENDS WHEN THE X-INTERVAL                      
C HAS BECOME LESS THEN EPS . IF SIGN(F(X1)-FW)= SIGN(F(X2)-FW)                  
C THEN SCHALT=.TRUE.  
      LOGICAL L1,LINKS,K,SCHALT                    
      SCHALT=.FALSE.
      EP=EPS  
      X1=X11          
      X2=X22          
      F1=FX11-FW     
      F2=FX22-FW     
      K=.FALSE.       
      NG=2       
      LFD=0  
      IF(F1*F2.LE.0.0) GOTO 200
        X=0.0           
        SCHALT=.TRUE.   
        RETURN
200   X=(X1*F2-X2*F1)/(F2-F1) 
      GOTO 400        
300     L1=LINKS        
        DX=(X2-X1)/NG
        IF(.NOT.LINKS) DX=DX*(NG-1)
        X=X1+DX
400   FX=F(X)-FW
      LFD=LFD+1
      IF(LFD.GT.20) THEN
        EP=EP*10.
        LFD=0
      ENDIF 
      LINKS=(F1*FX.GT.0.0)
      K=.NOT.K        
      IF(LINKS) THEN
        X1=X            
        F1=FX           
      ELSE
        X2=X 
        F2=FX 
      ENDIF   
      IF(ABS(X2-X1).LE.EP) GOTO 800               
      IF(K) GOTO 300  
      IF((LINKS.AND.(.NOT.L1)).OR.(.NOT.LINKS.AND.L1)) NG=2*NG                  
      GOTO 200        
800   RETURN          
      END             
C
C
C******************************************************************
C********** ZENITH ANGLE, DAY OF YEAR, TIME ***********************
C******************************************************************
C
C
        subroutine soco (ld,t,flat,Elon,height,
     &          DECLIN, ZENITH, SUNRSE, SUNSET)
c--------------------------------------------------------------------
c       s/r to calculate the solar declination, zenith angle, and
c       sunrise & sunset times  - based on Newbern Smith's algorithm
c       [leo mcnamara, 1-sep-86, last modified 16-jun-87]
c       {dieter bilitza, 30-oct-89, modified for IRI application}
c
c in:   ld      local day of year
c       t       local hour (decimal)
c       flat    northern latitude in degrees
c       elon    east longitude in degrees
c		height	height in km
c
c out:  declin      declination of the sun in degrees
c       zenith      zenith angle of the sun in degrees
c       sunrse      local time of sunrise in hours 
c       sunset      local time of sunset in hours 
c-------------------------------------------------------------------
c
        common/const/   dtr     /const1/humr,dumr
c amplitudes of Fourier coefficients  --  1955 epoch.................
        data    p1,p2,p3,p4,p6 /
     &  0.017203534,0.034407068,0.051610602,0.068814136,0.103221204 /
c
c s/r is formulated in terms of WEST longitude.......................
        wlon = 360. - Elon
c
c time of equinox for 1980...........................................
        td = ld + (t + Wlon/15.) / 24.
        te = td + 0.9369
c
c declination of the sun..............................................
        dcl = 23.256 * sin(p1*(te-82.242)) + 0.381 * sin(p2*(te-44.855))
     &      + 0.167 * sin(p3*(te-23.355)) - 0.013 * sin(p4*(te+11.97))
     &      + 0.011 * sin(p6*(te-10.41)) + 0.339137
        DECLIN = dcl
        dc = dcl * dtr
c
c the equation of time................................................
        tf = te - 0.5
        eqt = -7.38*sin(p1*(tf-4.)) - 9.87*sin(p2*(tf+9.))
     &      + 0.27*sin(p3*(tf-53.)) - 0.2*cos(p4*(tf-17.))
        et = eqt * dtr / 4.
c
        fa = flat * dtr
        phi = humr * ( t - 12.) + et
c
        a = sin(fa) * sin(dc)
        b = cos(fa) * cos(dc)
        	cosx = a + b * cos(phi)
        	if(abs(cosx).gt.1.) cosx=sign(1.,cosx)
        zenith = acos(cosx) / dtr
c
c calculate sunrise and sunset times --  at the ground...........
c see Explanatory Supplement to the Ephemeris (1961) pg 401......
c sunrise at height h metres is at...............................
		h=height*1000.
        chih = 90.83 + 0.0347 * sqrt(h)
c this includes corrections for horizontal refraction and........
c semi-diameter of the solar disk................................
        ch = cos(chih * dtr)
        cosphi = (ch -a ) / b
c if abs(secphi) > 1., sun does not rise/set.....................
c allow for sun never setting - high latitude summer.............
        secphi = 999999.
        if(cosphi.ne.0.) secphi = 1./cosphi
        sunset = 99.
        sunrse = 99.
        if(secphi.gt.-1.0.and.secphi.le.0.) return
c allow for sun never rising - high latitude winter..............
        sunset = -99.
        sunrse = -99.
        if(secphi.gt.0.0.and.secphi.lt.1.) return
c
        	cosx = cosphi
        	if(abs(cosx).gt.1.) cosx=sign(1.,cosx)
        phi = acos(cosx)
        et = et / humr
        phi = phi / humr
        sunrse = 12. - phi - et
        sunset = 12. + phi - et
        if(sunrse.lt.0.) sunrse = sunrse + 24.
        if(sunset.ge.24.) sunset = sunset - 24.
c
        return
        end
c
C
      FUNCTION HPOL(HOUR,TW,XNW,SA,SU,DSA,DSU)            
C-------------------------------------------------------
C PROCEDURE FOR SMOOTH TIME-INTERPOLATION USING EPSTEIN  
C STEP FUNCTION AT SUNRISE (SA) AND SUNSET (SU). THE 
C STEP-WIDTH FOR SUNRISE IS DSA AND FOR SUNSET DSU.
C TW,NW ARE THE DAY AND NIGHT VALUE OF THE PARAMETER TO 
C BE INTERPOLATED. SA AND SU ARE TIME OF SUNRIES AND 
C SUNSET IN DECIMAL HOURS.
C BILITZA----------------------------------------- 1979.
        IF(ABS(SU).GT.25.) THEN
                IF(SU.GT.0.0) THEN
                        HPOL=TW
                ELSE
                        HPOL=XNW
                ENDIF
                RETURN
        ENDIF
      HPOL=XNW+(TW-XNW)*EPST(HOUR,DSA,SA)+
     &  (XNW-TW)*EPST(HOUR,DSU,SU) 
      RETURN          
      END       
C      
C
        SUBROUTINE MODA(IN,IYEAR,MONTH,IDAY,IDOY,NRDAYMO)
C-------------------------------------------------------------------
C CALCULATES DAY OF YEAR (IDOY, ddd) FROM YEAR (IYEAR, yy or yyyy), 
C MONTH (MONTH, mm) AND DAY OF MONTH (IDAY, dd) IF IN=0, OR MONTH 
C AND DAY FROM YEAR AND DAY OF YEAR IF IN=1. NRDAYMO is an output 
C parameter providing the number of days in the specific month.
C-------------------------------------------------------------------
        DIMENSION       MM(12)
        DATA            MM/31,28,31,30,31,30,31,31,30,31,30,31/

        IMO=0
        MOBE=0
c
c  leap year rule: years evenly divisible by 4 are leap years, except
c  years also evenly divisible by 100 are not leap years, except years 
c  also evenly divisible by 400 are leap years. The year 2000 therefore 
C  is a leap year. The 100 and 400 year exception rule
c     if((iyear/4*4.eq.iyear).and.(iyear/100*100.ne.iyear)) mm(2)=29
c  will become important again in the year 2100 which is not a leap 
C  year.
c
        mm(2)=28
        if(iyear/4*4.eq.iyear) mm(2)=29

        IF(IN.GT.0) GOTO 5
                mosum=0
                if(month.gt.1) then
                        do 1234 i=1,month-1 
1234                            mosum=mosum+mm(i)
                        endif
                idoy=mosum+iday
                nrdaymo=mm(month)
                RETURN

5       IMO=IMO+1
                IF(IMO.GT.12) GOTO 55
                MOOLD=MOBE
                nrdaymo=mm(imo)
                MOBE=MOBE+nrdaymo
                IF(MOBE.LT.IDOY) GOTO 5
55              MONTH=IMO
                IDAY=IDOY-MOOLD
        RETURN
        END             
c
c
        subroutine ut_lt(mode,ut,slt,glong,iyyy,ddd)
c -----------------------------------------------------------------
c Converts Universal Time UT (decimal hours) into Solar Local Time
c SLT (decimal hours) for given date (iyyy is year, e.g. 1995; ddd
c is day of year, e.g. 1 for Jan 1) and geodatic longitude in degrees.
C For mode=0 UT->LT and for mode=1 LT->UT
c Please NOTE that iyyy and ddd are input as well as output parameters
c since the determined LT may be for a day before or after the UT day.
c ------------------------------------------------- bilitza nov 95
        integer         ddd,dddend

        xlong=glong
        if(glong.gt.180) xlong=glong-360
        if(mode.ne.0) goto 1
c
c UT ---> LT
c
        SLT=UT+xlong/15.
        if((SLT.ge.0.).and.(SLT.le.24.)) goto 2
        if(SLT.gt.24.) goto 3
                SLT=SLT+24.
                ddd=ddd-1
                if(ddd.lt.1.) then
                        iyyy=iyyy-1
                        ddd=365
c
c leap year if evenly divisible by 4 and not by 100, except if evenly
c divisible by 400. Thus 2000 will be a leap year.
c
                        if(iyyy/4*4.eq.iyyy) ddd=366
                        endif
                goto 2
3               SLT=SLT-24.
                ddd=ddd+1
                dddend=365
                if(iyyy/4*4.eq.iyyy) dddend=366
                if(ddd.gt.dddend) then
                        iyyy=iyyy+1
                        ddd=1
                        endif
                goto 2
c
c LT ---> UT
c
1       UT=SLT-xlong/15.
        if((UT.ge.0.).and.(UT.le.24.)) goto 2
        if(UT.gt.24.) goto 5
                UT=UT+24.
                ddd=ddd-1
                if(ddd.lt.1.) then
                        iyyy=iyyy-1
                        ddd=365
                        if(iyyy/4*4.eq.iyyy) ddd=366
                        endif
                goto 2
5               UT=UT-24.
                ddd=ddd+1
                dddend=365
                if(iyyy/4*4.eq.iyyy) dddend=366
                if(ddd.gt.dddend) then
                        iyyy=iyyy+1
                        ddd=1
                        endif
2       return
        end
C
C
       SUBROUTINE CLCMLT(IYYYY,DDD,UTHR,GLAT,GLON,MLT)
C--------------------------------------------------------------------
C      calculates magnetic local time
C      Inputs:
C             IYYYY..Year as YYYY, e.g. 1998
C             DDD..day of year (1.1. = 0)
C             UTHR..universal time in decimal hours
C             GLAT,GLON..latitude north and longitude east in degrees
C      Output:
C             MLT..magnetic local time in decimal hours
C--------------------------------------------------------------------
       INTEGER IYYYY,DDD
       REAL UTHR,GLAT,GLON,MLT
       REAL DTOR,PI,XG,YG,ZG
       REAL XXM(3),YYM(3),ZZM(3)
       INTEGER IHOUR,MIN,ISEC
       REAL GST,SLONG,SRASN,SDEC
       REAL BE,CAL,SA(3),S,C,SG(3),SM(3)
       REAL LAM,LAMS,DELLAM 
       DATA DTOR/0.017453293/
       DATA PI/3.14159265/

       XG=COS(GLAT*DTOR)*COS(GLON*DTOR)
       YG=COS(GLAT*DTOR)*SIN(GLON*DTOR)
       ZG=SIN(GLAT*DTOR)
       CALL DPMTRX(IYYYY,DDD,XXM,YYM,ZZM)
       
C       transform
       XM=XXM(1)*XG+XXM(2)*YG+XXM(3)*ZG
       YM=YYM(1)*XG+YYM(2)*YG+YYM(3)*ZG
       ZM=ZZM(1)*XG+ZZM(2)*YG+ZZM(3)*ZG
C       
       IHOUR=INT(UTHR)
       MIN=INT((UTHR-IHOUR)*60)
       ISEC=INT((UTHR-IHOUR-MIN/60.0)*3600)
       CALL SUN (IYYYY,DDD+1,IHOUR,MIN,ISEC,GST,SLONG,SRASN,SDEC)
       BE=GST
       CAL=COS(SRASN)
       SA(3)=SIN(SDEC)
       SA(1)=COS(SDEC)
       SA(2)=SA(1)*SIN(SRASN)
       SA(1)=SA(1)*CAL
       S=SIN(BE)
       C=COS(BE)
       SG(1)=C*SA(1)+S*SA(2)
       SG(2)=C*SA(2)-S*SA(1)
       SG(3)=SA(3)       
C       transform
       SM(1)=XXM(1)*SG(1)+XXM(2)*SG(2)+XXM(3)*SG(3)
       SM(2)=YYM(1)*SG(1)+YYM(2)*SG(2)+YYM(3)*SG(3)
       SM(3)=ZZM(1)*SG(1)+ZZM(2)*SG(2)+ZZM(3)*SG(3)
C      
       LAM=ATAN2(YM,XM)
       LAMS=ATAN2(SM(2),SM(1))
       DELLAM=LAM-LAMS
       IF (DELLAM .LT. 0.) DELLAM=DELLAM+2*PI
       MLT=AMOD(DELLAM/PI*12.+12.,24.)
       RETURN
       END
C
C
       SUBROUTINE DPMTRX(IYYYY,DDD,XM,YM,ZM)
C--------------------------------------------------------------------------
C      calculates othonormal matrix (columns XM,YM,ZM) for transformation 
C      from geographic to magnetic coordinates
C      Inputs:
C             IYYYY..year
C               DDD..day of year (1.1 = 0)
C      Outputs:
C               XM,YM,ZM..colums of the matrix
C      Notes:
C      MX(N),MY(N),MZ(N)..coordinates of the B vector in geographic system 
C                for years stored in YR(N)
C      N..number of elements of arrays MX,MY,MZ and YR
C--------------------------------------------------------------------------
       INTEGER IYYYY,DDD
       REAL XM(3),YM(3),ZM(3)
       REAL YR(10),MX(10),MY(10),MZ(10)
       REAL INTERP,YEAR
       REAL M,MXI,MYI,MZI,ZM12
       INTEGER N

       COMMON /DIPOL/ GHI1,GHI2,GHI3

       DATA N/10/

c IGRF coefficients (dipole) calculated in FELDCOF in IGRF.FOR
       MXI = -GHI2
       MYI = -GHI3
       MZI = -GHI1

C normalization of the vector of the dipole exis of the magnetic field
       M=SQRT(MXI*MXI+MYI*MYI+MZI*MZI)
       MYZ=SQRT(MYI*MYI+MZI*MZI)
       ZM(1)=MXI/M
       ZM(2)=MYI/M
       ZM(3)=MZI/M
       ZM12=SQRT(ZM(1)*ZM(1)+ZM(2)*ZM(2))
       YM(1)=-ZM(2)/ZM12
       YM(2)=ZM(1)/ZM12
       YM(3)=0.
       XM(1)=YM(2)*ZM(3)-YM(3)*ZM(2)
       XM(2)=YM(3)*ZM(1)-YM(1)*ZM(3)
       XM(3)=YM(1)*ZM(2)-YM(2)*ZM(1)
       RETURN
       END
C
C
      SUBROUTINE SUN (IYEAR,IDAY,IHOUR,MIN,ISEC,GST,SLONG,SRASN,SDEC)
C-----------------------------------------------------------------------------
C  CALCULATES FOUR QUANTITIES NECESSARY FOR COORDINATE TRANSFORMATIONS
C  WHICH DEPEND ON SUN POSITION (AND, HENCE, ON UNIVERSAL TIME AND SEASON)
C
C-------  INPUT PARAMETERS:
C  IYR,IDAY,IHOUR,MIN,ISEC -  YEAR, DAY, AND UNIVERSAL TIME IN HOURS, MINUTES,
C    AND SECONDS  (IDAY=1 CORRESPONDS TO JANUARY 1).
C
C-------  OUTPUT PARAMETERS:
C  GST - GREENWICH MEAN SIDEREAL TIME, SLONG - LONGITUDE ALONG ECLIPTIC
C  SRASN - RIGHT ASCENSION,  SDEC - DECLINATION  OF THE SUN (RADIANS)
C  ORIGINAL VERSION OF THIS SUBROUTINE HAS BEEN COMPILED FROM:
C  RUSSELL, C.T., COSMIC ELECTRODYNAMICS, 1971, V.2, PP.184-196.
C
C  LAST MODIFICATION:  MARCH 31, 2003 (ONLY SOME NOTATION CHANGES)
C
C     ORIGINAL VERSION WRITTEN BY:    Gilbert D. Mead
C-----------------------------------------------------------------------------
C
      DOUBLE PRECISION DJ,FDAY
      DATA RAD/57.295779513/
C
      IF(IYEAR.LT.1901.OR.IYEAR.GT.2099) RETURN
      FDAY=DFLOAT(IHOUR*3600+MIN*60+ISEC)/86400.D0
      DJ=365*(IYEAR-1900)+(IYEAR-1901)/4+IDAY-0.5D0+FDAY
      T=DJ/36525.
      VL=DMOD(279.696678+0.9856473354*DJ,360.D0)
      GST=DMOD(279.690983+.9856473354*DJ+360.*FDAY+180.,360.D0)/RAD
      G=DMOD(358.475845+0.985600267*DJ,360.D0)/RAD
      SLONG=(VL+(1.91946-0.004789*T)*SIN(G)+0.020094*SIN(2.*G))/RAD
      IF(SLONG.GT.6.2831853) SLONG=SLONG-6.2831853
      IF (SLONG.LT.0.) SLONG=SLONG+6.2831853
      OBLIQ=(23.45229-0.0130125*T)/RAD
      SOB=SIN(OBLIQ)
      SLP=SLONG-9.924E-5
C
C   THE LAST CONSTANT IS A CORRECTION FOR THE ANGULAR ABERRATION  DUE TO
C   THE ORBITAL MOTION OF THE EARTH
C
      SIN1=SOB*SIN(SLP)
      COS1=SQRT(1.-SIN1**2)
      SC=SIN1/COS1
      SDEC=ATAN(SC)
      SRASN=3.141592654-ATAN2(COS(OBLIQ)/SOB*SC,-COS(SLP)/COS1)
      RETURN
      END
C      
C
C *********************************************************************
C ************************ EPSTEIN FUNCTIONS **************************
C *********************************************************************
C REF:  H. G. BOOKER, J. ATMOS. TERR. PHYS. 39, 619-623, 1977
C       K. RAWER, ADV. SPACE RES. 4, #1, 11-15, 1984
C *********************************************************************
C
C
        REAL FUNCTION  RLAY ( X, XM, SC, HX )
C -------------------------------------------------------- RAWER  LAYER
        Y1  = EPTR ( X , SC, HX )
        Y1M = EPTR ( XM, SC, HX )
        Y2M = EPST ( XM, SC, HX )
        RLAY = Y1 - Y1M - ( X - XM ) * Y2M / SC
        RETURN
        END
C
C
        REAL FUNCTION D1LAY ( X, XM, SC, HX )
C ------------------------------------------------------------ dLAY/dX
        D1LAY = ( EPST(X,SC,HX) - EPST(XM,SC,HX) ) /  SC
        RETURN
        END
C
C
        REAL FUNCTION D2LAY ( X, XM, SC, HX )
C ---------------------------------------------------------- d2LAY/dX2
        D2LAY = EPLA(X,SC,HX) /  (SC * SC)
        RETURN
        END
C
C
        REAL FUNCTION EPTR ( X, SC, HX )
C --------------------------------------------------------- TRANSITION
        COMMON/ARGEXP/ARGMAX
        D1 = ( X - HX ) / SC
        IF (ABS(D1).LT.ARGMAX) GOTO 1
        IF (D1.GT.0.0) THEN
          EPTR = D1
        ELSE
          EPTR = 0.0
        ENDIF
        RETURN
1       EPTR = ALOG ( 1. + EXP( D1 ))
        RETURN
        END
C
C
        REAL FUNCTION EPST ( X, SC, HX )
C -------------------------------------------------------------- STEP
        COMMON/ARGEXP/ARGMAX
        D1 = ( X - HX ) / SC
        IF (ABS(D1).LT.ARGMAX) GOTO 1
        IF (D1.GT.0.0) THEN
          EPST = 1.
        ELSE
          EPST = 0.
        ENDIF
        RETURN
1       EPST = 1. / ( 1. + EXP( -D1 ))
        RETURN
        END
C
C
        REAL FUNCTION EPSTEP ( Y2, Y1, SC, HX, X)
C---------------------------------------------- STEP FROM Y1 TO Y2      
        EPSTEP = Y1 + ( Y2 - Y1 ) * EPST ( X, SC, HX)
        RETURN
        END
C
C
        REAL FUNCTION EPLA ( X, SC, HX )
C ------------------------------------------------------------ PEAK 
        COMMON/ARGEXP/ARGMAX
        D1 = ( X - HX ) / SC
        IF (ABS(D1).LT.ARGMAX) GOTO 1
                EPLA = 0
                RETURN  
1       D0 = EXP ( D1 )
        D2 = 1. + D0
        EPLA = D0 / ( D2 * D2 )
        RETURN
        END
c
c
        FUNCTION XE2TO5(H,HMF2,NL,HX,SC,AMP)
C----------------------------------------------------------------------
C NORMALIZED ELECTRON DENSITY (N/NMF2) FOR THE MIDDLE IONOSPHERE FROM 
C HME TO HMF2 USING LAY-FUNCTIONS.
C----------------------------------------------------------------------
        DIMENSION       HX(NL),SC(NL),AMP(NL)
        SUM = 1.0
        DO 1 I=1,NL
           YLAY = AMP(I) * RLAY( H, HMF2, SC(I), HX(I) )
           zlay=10.**ylay
1          sum=sum*zlay
        XE2TO5 = sum
        RETURN
        END
C
C
        REAL FUNCTION XEN(H,HMF2,XNMF2,HME,NL,HX,SC,AMP)
C----------------------------------------------------------------------
C ELECTRON DENSITY WITH NEW MIDDLE IONOSPHERE
C----------------------------------------------------------------------
        DIMENSION       HX(NL),SC(NL),AMP(NL)
C
        IF(H.LT.HMF2) GOTO 100
                XEN = XE1(H)
                RETURN
100     IF(H.LT.HME) GOTO 200
                XEN = XNMF2 * XE2TO5(H,HMF2,NL,HX,SC,AMP)
                RETURN
200     XEN = XE6(H)
        RETURN
        END
C
C
        SUBROUTINE ROGUL(IDAY,XHI,SX,GRO)
C --------------------------------------------------------------------- 
C   CALCULATES RATIO H0.5/HMF2 FOR HALF-DENSITY POINT (NE(H0.5)=0.5*
C   NMF2) T. GULYAEVA, ADVANCES IN SPACE RESEARCH 7, #6, 39-48, 1987.
C
C       INPUT:  IDAY    DAY OF YEAR
C               XHI     SOLAR ZENITH ANGLE [DEGREE]
C       
C       OUTPUT: GRO     RATIO OF HALF DENSITY HEIGHT TO F PEAK HEIGHT
C               SX      SMOOTHLY VARYING SEASON PARAMTER (SX=1 FOR 
C                       DAY=1; SX=3 FOR DAY=180; SX=2 FOR EQUINOX)
C ---------------------------------------------------------------------
C
        common  /const1/humr,dumr
        SX = 2. - COS ( IDAY * dumr )
        XS = ( XHI - 20. * SX) / 15.
        GRO = 0.8 - 0.2 / ( 1. + EXP(XS) )
c same as gro=0.6+0.2/(1+exp(-xs))
        RETURN
        END
C
C
        SUBROUTINE LNGLSN ( N, A, B, AUS)
C --------------------------------------------------------------------
C SOLVES QUADRATIC SYSTEM OF LINEAR EQUATIONS:
C
C       INPUT:  N       NUMBER OF EQUATIONS (= NUMBER OF UNKNOWNS)
C               A(N,N)  MATRIX (LEFT SIDE OF SYSTEM OF EQUATIONS)
C               B(N)    VECTOR (RIGHT SIDE OF SYSTEM)
C
C       OUTPUT: AUS     =.TRUE.   NO SOLUTION FOUND
C                       =.FALSE.  SOLUTION IS IN  A(N,J) FOR J=1,N
C --------------------------------------------------------------------
C
        DIMENSION       A(5,5), B(5), AZV(10)
        LOGICAL         AUS
C
        NN = N - 1
        AUS = .FALSE.
        DO 1 K=1,N-1
                IMAX = K
                L    = K
                IZG  = 0
                AMAX  = ABS( A(K,K) )
110             L = L + 1
                IF (L.GT.N) GOTO 111
                HSP = ABS( A(L,K) )
                IF (HSP.LT.1.E-8) IZG = IZG + 1
                IF (HSP.LE.AMAX) GOTO 110
111             IF (ABS(AMAX).GE.1.E-10) GOTO 133
                        AUS = .TRUE.
                        RETURN
133             IF (IMAX.EQ.K) GOTO 112
                DO 2 L=K,N
                        AZV(L+1)  = A(IMAX,L)
                        A(IMAX,L) = A(K,L)
2                       A(K,L)    = AZV(L+1)
                AZV(1)  = B(IMAX)
                B(IMAX) = B(K)
                B(K)    = AZV(1)
112             IF (IZG.EQ.(N-K)) GOTO 1
                AMAX = 1. / A(K,K)
                AZV(1) = B(K) * AMAX
                DO 3 M=K+1,N
3                       AZV(M+1) = A(K,M) * AMAX
                DO 4 L=K+1,N
                        AMAX = A(L,K)
                        IF (ABS(AMAX).LT.1.E-8) GOTO 4
                        A(L,K) = 0.0
                        B(L) = B(L) - AZV(1) * AMAX
                        DO 5 M=K+1,N
5                               A(L,M) = A(L,M) - AMAX * AZV(M+1)
4               CONTINUE
1       CONTINUE
        DO 6 K=N,1,-1
                AMAX = 0.0
                IF (K.LT.N) THEN
                        DO 7 L=K+1,N
7                               AMAX = AMAX + A(K,L) * A(N,L)
                        ENDIF
                IF (ABS(A(K,K)).LT.1.E-6) THEN
                        A(N,K) = 0.0
                ELSE
                        A(N,K) = ( B(K) - AMAX ) / A(K,K)
                ENDIF
6       CONTINUE
        RETURN
        END
C
C
        SUBROUTINE LSKNM ( N, M, M0, M1, HM, SC, HX, W,X,Y,VAR,SING)
C --------------------------------------------------------------------
C   DETERMINES LAY-FUNCTIONS AMPLITUDES FOR A NUMBER OF CONSTRAINTS:
C
C       INPUT:  N       NUMBER OF AMPLITUDES ( LAY-FUNCTIONS)
C               M       NUMBER OF CONSTRAINTS
C               M0      NUMBER OF POINT CONSTRAINTS
C               M1      NUMBER OF FIRST DERIVATIVE CONSTRAINTS
C               HM      F PEAK ALTITUDE  [KM]
C               SC(N)   SCALE PARAMETERS FOR LAY-FUNCTIONS  [KM]
C               HX(N)   HEIGHT PARAMETERS FOR LAY-FUNCTIONS  [KM]
C               W(M)    WEIGHT OF CONSTRAINTS
C               X(M)    ALTITUDES FOR CONSTRAINTS  [KM]
C               Y(M)    LOG(DENSITY/NMF2) FOR CONSTRAINTS
C
C       OUTPUT: VAR(M)  AMPLITUDES
C               SING    =.TRUE.   NO SOLUTION
C ---------------------------------------------------------------------
C
        LOGICAL         SING
        DIMENSION       VAR(N), HX(N), SC(N), W(M), X(M), Y(M),
     &                  BLI(5), ALI(5,5), XLI(5,10)
C
        M01=M0+M1
        SCM=0
        DO 1 J=1,5
                BLI(J) = 0.
                DO 1 I=1,5
1                       ALI(J,I) = 0. 
        DO 2 I=1,N
                DO 3 K=1,M0
3                       XLI(I,K) = RLAY( X(K), HM, SC(I), HX(I) )
                DO 4 K=M0+1,M01
4                       XLI(I,K) = D1LAY( X(K), HM, SC(I), HX(I) )
                DO 5 K=M01+1,M
5                       XLI(I,K) = D2LAY( X(K), HM, SC(I), HX(I) )
2       CONTINUE
                DO 7 J=1,N
                DO 6 K=1,M
                        BLI(J) = BLI(J) + W(K) * Y(K) * XLI(J,K)
                        DO 6 I=1,N
6                               ALI(J,I) = ALI(J,I) + W(K) * XLI(I,K) 
     &                                  * XLI(J,K)
7       CONTINUE
        CALL LNGLSN( N, ALI, BLI, SING )
        IF (.NOT.SING) THEN
                DO 8 I=1,N
8                       VAR(I) = ALI(N,I)
                ENDIF
        RETURN
        END
C
C
        SUBROUTINE INILAY(NIGHT,F1REG,XNMF2,XNMF1,XNME,VNE,HMF2,HMF1, 
     &                          HME,HV1,HV2,HHALF,HXL,SCL,AMP,IQUAL)
C-------------------------------------------------------------------
C CALCULATES AMPLITUDES FOR LAY FUNCTIONS
C D. BILITZA, DECEMBER 1988
C
C INPUT:        NIGHT   LOGICAL VARIABLE FOR DAY/NIGHT DISTINCTION
C               F1REG   LOGICAL VARIABLE FOR F1 OCCURRENCE
C               XNMF2   F2 PEAK ELECTRON DENSITY [M-3]
C               XNMF1   F1 PEAK ELECTRON DENSITY [M-3]
C               XNME    E  PEAK ELECTRON DENSITY [M-3]
C               VNE     ELECTRON DENSITY AT VALLEY BASE [M-3]
C               HMF2    F2 PEAK ALTITUDE [KM]
C               HMF1    F1 PEAK ALTITUDE [KM]
C               HME     E  PEAK ALTITUDE [KM]
C               HV1     ALTITUDE OF VALLEY TOP [KM]
C               HV2     ALTITUDE OF VALLEY BASE [KM]
C               HHALF   ALTITUDE OF HALF-F2-PEAK-DENSITY [KM]
C
C OUTPUT:       HXL(4)  HEIGHT PARAMETERS FOR LAY FUNCTIONS [KM] 
C               SCL(4)  SCALE PARAMETERS FOR LAY FUNCTIONS [KM]
C               AMP(4)  AMPLITUDES FOR LAY FUNCTIONS
C               IQUAL   =0 ok, =1 ok using second choice for HXL(1)
C                       =2 NO SOLUTION
C---------------------------------------------------------------  
        DIMENSION       XX(8),YY(8),WW(8),AMP(4),HXL(4),SCL(4)
        LOGICAL         SSIN,NIGHT,F1REG
c
c constants --------------------------------------------------------
                NUMLAY=4
                NC1 = 2
                ALG102=ALOG10(2.)
c
c constraints: xx == height     yy == log(Ne/NmF2)    ww == weights
c -----------------------------------------------------------------
                ALOGF = ALOG10(XNMF2)
                ALOGEF = ALOG10(XNME) - ALOGF
                XHALF=XNMF2/2.
                XX(1) = HHALF
                XX(2) = HV1
                XX(3) = HV2
                XX(4) = HME
                XX(5) = HME - ( HV2 - HME )
                YY(1) = -ALG102
                YY(2) = ALOGEF
                YY(3) = ALOG10(VNE) - ALOGF
                YY(4) = ALOGEF
                YY(5) = YY(3)
                YY(7) = 0.0
                WW(2) = 1.
                WW(3) = 2.
                WW(4) = 5.
c
c geometric paramters for LAY -------------------------------------
c difference to earlier version:  HXL(3) = HV2 + SCL(3)
c
                SCL0 = 0.7 * ( 0.216 * ( HMF2 - HHALF ) + 56.8 )
                SCL(1) = 0.8 * SCL0
                SCL(2) = 10.
                SCL(3) = 9.
                SCL(4) = 6.
                HXL(3) = HV2
                HFFF=HHALF
                XFFF=XHALF
c
C DAY CONDITION--------------------------------------------------
c earlier tested:       HXL(2) = HMF1 + SCL(2)
c 
            IF(NIGHT) GOTO 7711
                NUMCON = 8
                HXL(1) = 0.9 * HMF2
                  HXL1T  = HHALF
                HXL(2) = HMF1
                HXL(4) = HME - SCL(4)
                XX(6) = HMF1
                XX(7) = HV2
                XX(8) = HME
                YY(8) = 0.0
                WW(5) = 1.
                WW(7) = 50.
                WW(8) = 500.
c without F-region ----------------------------------------------
                IF(F1REG) GOTO 100
                        HXL(2)=(HMF2+HHALF)/2.
                        YY(6) = 0.
                        WW(6) = 0.
                        WW(1) = 1.
                        GOTO 7722
c with F-region --------------------------------------------
100             YY(6) = ALOG10(XNMF1) - ALOGF
                WW(6) = 3.
                IF((XNMF1-XHALF)*(HMF1-HHALF).LT.0.0) THEN
                  WW(1)=0.5
                ELSE
                  ZET = YY(1) - YY(6)
                  WW(1) = EPST( ZET, 0.1, 0.15)
                ENDIF
                IF(HHALF.GT.HMF1) THEN
                  HFFF=HMF1
                  XFFF=XNMF1
                ELSE
                  HFFF=HHALF
                  XFFF=XHALF
                ENDIF
                GOTO 7722
c
C NIGHT CONDITION---------------------------------------------------
c different HXL,SCL values were tested including: 
c       SCL(1) = HMF2 * 0.15 - 27.1     HXL(2) = 200.   
c       HXL(2) = HMF1 + SCL(2)          HXL(3) = 140.
c       SCL(3) = 5.                     HXL(4) = HME + SCL(4)
c       HXL(4) = 105.                   
c
7711            NUMCON = 7
                HXL(1) = HHALF
                  HXL1T  = 0.4 * HMF2 + 30.
                HXL(2) = ( HMF2 + HV1 ) / 2.
                HXL(4) = HME
                XX(6) = HV2
                XX(7) = HME
                YY(6) = 0.0
                WW(1) = 1.
                WW(3) = 3.
                WW(5) = 0.5
                WW(6) = 50.
                WW(7) = 500.
                HFFF=HHALF
                XFFF=XHALF
c
C are valley-top and bottomside point compatible ? -------------
C
7722    IF((HV1-HFFF)*(XNME-XFFF).LT.0.0) WW(2)=0.5
        IF(HV1.LE.HV2+5.0) WW(2)=0.5
c
C DETERMINE AMPLITUDES-----------------------------------------
C
            NC0=NUMCON-NC1
            IQUAL=0
2299        CALL LSKNM(NUMLAY,NUMCON,NC0,NC1,HMF2,SCL,HXL,WW,XX,YY,
     &          AMP,SSIN)
                IF(IQUAL.gt.0) GOTO 1937
            IF((ABS(AMP(1)).GT.10.0).OR.(SSIN)) THEN
                IQUAL=1
                HXL(1)=HXL1T
                GOTO 2299
                ENDIF
1937        IF(SSIN) IQUAL=2
            RETURN
            END
c
c
           subroutine read_ig_rz 
c----------------------------------------------------------------
c Reads the Rz12 and IG12 indices file IG_RZ.DAT from I/O UNIT=12 
c and stores the indices in COMMON:
c		common/igrz/aig,arziyst,iyed   with aig(806),arz(806),
c											start year (iyst)
c                                           end year (iyed)
c 
c The indices file IG_RZ.DAT is structured as follows (values are 
c separated by comma): 
c   day, month, year of the last update of this file,
c   a blank line
c   start month, start year, end month, end year,
c   a blank line
c   the IG index for December of start year minus 1 (this value is 
c		needed for interpolating from 1st to 15th of first year)
c   the 12 IG indices (13-months running mean) for start year, 
c   the 12 IG indices for the second year 
c       .. and so on until the last year,
c   the 12 IG indices for the last year 
c   the IG index for January of end year plus 1 (needed for interpolation)
c   a blank line
c   the Rz index for December of start year minus 1 
c   the 12 Rz indices (13-months running mean) for the start year,
c   the 12 Rz indices for the second year 
c       .. and so on until the last year.
c   the 12 Rz indices for the last year 
c   the Rz index for January of end year plus 1 
c 
c A negative Rz index means that the given index is the 13-months-
C running mean of the solar radio flux (F10.7). The close correlation 
C between (Rz)12 and (F10.7)12 is used to compute the (Rz)12 indices.
c
c An IG index of -111 indicates that no IG values are available for the
c time period. In this case a correlation function between (IG)12 and 
C (Rz)12 is used to obtain (IG)12.
c
c The computation of the 13-month-running mean for month M requires the
c indices for the six months preceeding M and the six months following 
C M (month: M-6, ..., M+6). To calculate the current running mean one 
C therefore requires predictions of the indix for the next six months. 
C Starting from six months before the UPDATE DATE (listed at the top of 
c the file) and onward the indices are therefore based on indices 
c predictions.
c----------------------------------------------------------------

           integer	iyst,iyend,iymst,iupd,iupm,iupy,imst,imend
           real		aig(806),arz(806)
           
           common /igrz/aig,arz,iymst,iymend

           open(unit=12,file='ig_rz.dat',FORM='FORMATTED',status='old')

c-web- special for web version
c            open(unit=12,file=
c     *         '/var/www/omniweb/cgi/vitmo/IRI/ig_rz.dat',
c     *         FORM='FORMATTED',status='old')

c Read the update date, the start date and the end date (mm,yyyy), and
c get number of data points to read.

            read(12,*) iupd,iupm,iupy
            read(12,*) imst,iyst,imend,iyend
            iymst=iyst*100+imst
            iymend=iyend*100+imend

c inum_vals= 12-imst+1+(iyend-iyst-1)*12 +imend + 2
c 1st year \ full years       \last y\ before & after

            inum_vals= 3-imst+(iyend-iyst)*12 +imend

c read all the IG12 (ionoindx) and Rz12 (indrz) values
            read(12,*) (aig(i),i=1,inum_vals)
            read(12,*) (arz(i),i=1,inum_vals)

c use scale factor 0.7 for new sunspot number starting from Jan 2014
c and starting with ig_rz file for Oct 2016.
            if(iupy*100+iupm.gt.201609) then
                 inum_chan= 3-imst+(2014-iyst)*12
                 do 1 jj=inum_chan,inum_vals
                    arz(jj)=arz(jj)*0.7
c                ggg=aig(jj)
c                if(rrr.lt.0.0) then
c                    covr=abs(rrr)
c                    rrr=33.52*sqrt(covr+85.12)-408.99
c                    if(rrr.lt.0.0) rrr=0.0
c                    endif
c                if(ggg.le.-90.) then
c                    zi=-12.349154+(1.4683266-2.67690893e-03*rrr)*rrr
c                    if(zi.gt.274.0) zi=274.0
c                    ggg=zi
c                    endif
c                arz(jj)=rrr
c                aig(jj)=ggg   
1                   continue
                 endif
                 
            close(unit=12)

            return
            end
c
c
           subroutine tcon(yr,mm,day,idn,rz,ig,rsn,nmonth)
c----------------------------------------------------------------
c input:        yr,mm,day       year(yyyy),month(mm),day(dd)
c               idn             day of year(ddd)
c output:       rz(3)           12-month-smoothed solar sunspot number
c               ig(3)           12-month-smoothed IG index
c               rsn             interpolation parameter
c               nmonth          previous or following month depending
c                               on day
c
c Uses read_ig_rz and common/igrz/ to get indices 
c 
c rz(1) & ig(1) contain the indices for the month mm and rz(2) & ig(2)
c for the previous month (if day less than 15) or for the following
c month (if day greater than 15). These indices are for the mid of the 
c month. The indices for the given day are obtained by linear 
c interpolation and are stored in rz(3) and ig(3).
c----------------------------------------------------------------

           integer	yr,mm,day,iyst,iyend,iymst
           integer	imst,iymend
           real		ionoindx(806),indrz(806)
           real		ig(3),rz(3)
           logical	mess
           
           common 	/iounit/konsol,mess  
           common	/igrz/ionoindx,indrz,iymst,iymend

        iytmp=yr*100+mm
        if (iytmp.lt.iymst.or.iytmp.gt.iymend) then
               if(mess) write(konsol,8000) iytmp,iymst,iymend
8000           format(1x,I10,'** OUT OF RANGE **'/,5x,
     &  'The file IG_RZ.DAT which contains the indices Rz12',
     &  ' and IG12'/5x,'currently only covers the time period',
     &  ' (yymm) : ',I6,'-',I6)
               nmonth=-1
               return
               endif

		iyst=iymst/100
		imst=iymst-iyst*100
c       num=12-imst+1+(yr-iyst-1)*12+mm+1
        num=2-imst+(yr-iyst)*12+mm

        rz(1)=indrz(num)
        ig(1)=ionoindx(num)
        midm=15
        if(mm.eq.2) midm=14
        call MODA(0,yr,mm,midm,idd1,nrdaym)

        if(day.lt.midm) goto 1926
c day is at or after mid of month
                imm2=mm+1
                if(imm2.gt.12) then
                        imm2=1
                        iyy2=yr+1
                        idd2=380            ! =365+15 mid-January
c               if((yr/4*4.eq.yr).and.(yr/100*100.ne.yr)) idd2=381
                        if(yr/4*4.eq.yr) idd2=381
                else
                        iyy2=yr
                        midm=15
                        if(imm2.eq.2) midm=14
                        call MODA(0,iyy2,imm2,midm,IDD2,nrdaym)
                endif
                rz(2)=indrz(num+1)
                ig(2)=ionoindx(num+1)
                rsn=(idn-idd1)*1./(idd2-idd1)                
                rz(3)=rz(1)+(rz(2)-rz(1))*rsn
                ig(3)=ig(1)+(ig(2)-ig(1))*rsn
                goto 1927
1926            imm2=mm-1
                if(imm2.lt.1) then
                        imm2=12
                        idd2=-16
                        iyy2=yr-1
                else
                        iyy2=yr
                        midm=15
                        if(imm2.eq.2) midm=14
                        call MODA(0,iyy2,imm2,midm,IDD2,nrdaym)
                endif
                rz(2)=indrz(num-1)
                ig(2)=ionoindx(num-1)
                rsn=(idn-idd2)*1./(idd1-idd2)
                rz(3)=rz(2)+(rz(1)-rz(2))*rsn
                ig(3)=ig(2)+(ig(1)-ig(2))*rsn

1927    nmonth=imm2
            return
            end
C
C
		subroutine readapf107
C-------------------------------------------------------------------------
c Reads APF107.DAT file (on UNIT=13) and stores contents in COMMON block:
C 	COMMON/AAP,AF107,N/ with  AAP(23000,9) and AF107(23000,3)
C		AAP(*,1)	3-hour Ap indices for the UT interval )0-3)
C		AAP(*,2)	3-hour Ap indices for the UT interval )3-6)
C          ....                       ....
C		AAP(*,8)	3-hour Ap indices for the UT interval )21-6)
C		AAP(*,9)	daily Ap
C		AF107(*,1)	F10.7 radio flux for the day
C		AF107(*,2)	81-day average of F10.7 radio flux 
C		AF107(*,3)	365-day average of F10.7
C       N           total number of records
c
c APF107.DAT is structured as follows:
c 		JY(I3),JMN(I3),JD(I3)	year, month, day 
c		IIAP(8)	(8I3)			3-hour Ap indices for the UT intervals 
c								(0-3(,(3-6(,(6-9(, .., (18-21(,(21-24(
c		IAPD (I3)				daily Ap
c		IR (I3)					sunspot number for the day (empty)
c		F107 (F5.1)				F10.7 radio flux for the day
c		F107_81 (F5.1)			81-day average of F10.7 radio flux 
c       F107_365 (F5.1)         365-day average of F10.7 centered on 
c                               the date of interest. At start and end  
c								of index file it takes all available  
c                               indices, e.g. for the first date the 
c                               average is only over 40 F10.7 values  
c                               and over 41 values on the 2nd date.  
c
c If date is outside the range of the Ap indices file then IAP(1)=-5  
C-------------------------------------------------------------------------
C
        INTEGER		aap(23000,9),iiap(8)
        DIMENSION 	af107(23000,3)
        COMMON		/apfa/aap,af107,n

        Open(13,FILE='apf107.dat',FORM='FORMATTED',STATUS='OLD')
c-web-sepcial vfor web version
c      OPEN(13,FILE='/var/www/omniweb/cgi/vitmo/IRI/apf107.dat',
c     *    FORM='FORMATTED',STATUS='OLD')

		i=1
1       READ(13,10,END=21) JY,JMN,JD,iiap,iapda,IR,F107D,F107_81,
     *        F365
10      FORMAT(3I3,9I3,I3,3F5.1)

c 		adate(i)=jy*10000+jmn*100+jd 
		do j=1,8 
             aap(i,j)=iiap(j)
             enddo
		aap(i,9)=iapda
c		irza(i)=ir
 		if(F107_81.lt.-4.) F107_81=F107D
 		if(F107_365.lt.-4.) F107_365=F107D
		af107(i,1)=f107d 
          af107(i,2)=f107_81 
          af107(i,3)=f365
		i=i+1 
          goto 1

21		n=i-1
 
        CLOSE(13)
		return
		end
C
C

        SUBROUTINE APF(ISDATE,HOUR,IAP)
c-----------------------------------------------------------------------
c Finds 3-hourly Ap indices for IRI-STORM model
c    INPUTS: 	ISDATE		Array-index from APF_ONLY
c			    HOUR		UT in decimal hours
c    OUTPUT:    IAP(1:13)	3-hourly Ap index
c							IAP(13) Ap index for current UT
c							IAP(1) AP index for UT-39 hours.
c
c Gets indices from COMMON/APFA/
c
c If date is outside the range of the Ap indices file than IAP(1)=-5  
c-----------------------------------------------------------------------

        INTEGER		aap(23000,9),iiap(8),iap(13)
        DIMENSION 	af107(23000,3)
        LOGICAL 	mess
        COMMON 		/iounit/konsol,mess	/apfa/aap,af107,nf107
       
        do i=1,8
              iap(i)=-1
              enddo

	   IS = ISDATE

        ihour=int(hour/3.)+1
        if(ihour.gt.8) ihour=8

        if(is*8+ihour.lt.13) goto 21   ! less then 13 indices available	

        j1=13-ihour
        do i=1,ihour
           iapi=aap(is,i)
           if(iapi.lt.-2) goto 21
           iap(j1+i)=iapi
           enddo

        if(ihour.gt.4) then
           do i=1,j1
              iapi=aap(is-1,8-j1+i)
              if(iapi.lt.-2) goto 21
              iap(i)=iapi
              enddo
        else           
           j2=5-ihour
           do i=1,8
              iapi=aap(is-1,i)
              if(iapi.lt.-2) goto 21
              iap(j2+i)=iapi
              enddo
           do i=1,j2
              iapi=aap(is-2,8-j2+i)
              if(iapi.lt.-2) goto 21
              iap(i)=iapi
              enddo
        endif         
        goto 20
        
21      if(mess) write(konsol,100)
100     format(1X,'One of the ap indeces is negative.',
     &     ' STORM model is turned off.')
        IAP(1)=-5
      
20    RETURN
      END
C
C
        SUBROUTINE APFMSIS(ISDATE,HOUR,IAPO)
c-----------------------------------------------------------------------
c Finds 3-hourly Ap indices for NRLMSIS00 model 
c    INPUTS: 	ISDATE		Array-index from APF_ONLY
c				HOUR		UT in decimal hours
c    OUTPUT:   	IAPO(1:7)	3-hourly Ap index
C  
C IAPO(1) DAILY AP
C IAPO(2) 3-HR AP INDEX FOR CURRENT TIME			   	
C IAPO(3) 3-HR AP INDEX FOR 3 HRS BEFORE CURRENT TIME	
C IAPO(4) 3-HR AP INDEX FOR 6 HRS BEFORE CURRENT TIME	
C IAPO(5) 3-HR AP INDEX FOR 9 HRS BEFORE CURRENT TIME  
C IAPO(6) AVERAGE OF EIGHT 3-HR AP INDICIES FROM 12 TO 33 HRS PRIOR
C         TO CURRENT TIME
C IAPO(7) AVERAGE OF EIGHT 3 HR AP INDICIES FROM 36 TO 57 HRS PRIOR
C         TO CURRENT TIME
c
c The 3-hour UT intervals during the day are: (0-3),)3-6),)6-9),)9-12),
c )12-15),)15-18),)18-21),)21-24(.
c 
c If date is outside the range of the Ap indices file then IAPO(2)=-5  
c-----------------------------------------------------------------------
c
		REAL 		IAPO
        INTEGER		aap(23000,9),iiap(8)
        DIMENSION 	af107(23000,3),iap(20),lm(12),iapo(7)
        LOGICAL  	mess

        COMMON 		/iounit/konsol,mess	/apfa/aap,af107,nf107

        IS=ISDATE

        ihour=int(hour/3.)+1
        if(ihour.gt.8) ihour=8

		iapo(1)=aap(is,9)		

C There must be at least 20 indices available
        if((is-1)*8+ihour.lt.20) goto 21      	

C assemble Ap values as needed by MSIS
        j1=ihour+1
        do i=1,ihour
           iap(j1-i)=aap(is,i)
           enddo

        j1=ihour+9
        do i=1,8
            iap(j1-i)=aap(is-1,i)
        	enddo

        j1=ihour+17
        j2=8-(20-ihour-8)+1
        if(j2.lt.1) j2=1
        do i=j2,8
            iap(j1-i)=aap(is-2,i)
            enddo

        if(ihour.lt.4) then
          j1=ihour+25
          j2=8-(20-ihour-16)+1
          do i=j2,8
            iap(j1-i)=aap(is-3,i)
            enddo
          endif

        do 25 i=1,4 
25         iapo(i+1)=iap(i)*1.0

        sum1=0.
        sum2=0.
        do 26 i=1,8
           sum1=sum1+iap(4+i)
26         sum2=sum2+iap(12+i)
c        iapo(6)=int(sum1/8.+.5)
c        iapo(7)=int(sum2/8.+.5)
        iapo(6)=sum1/8.
        iapo(7)=sum2/8.
        goto 20
        
21      if(mess) write(konsol,100)
100     format(1X,'APFMSIS: No Ap dependence because date is not',
     &       ' covered by APF107.DAT indices file')
        IAPO(2)=-5.0
20    	continue

	  RETURN
      END
C
C
        SUBROUTINE APF_ONLY(IYYYY,IMN,ID,F107D,F107PD,F107_81,F107_365,
     *        IAPDA,ISDATE)
c-----------------------------------------------------------------------
c Finds daily F10.7, daily Ap, and 81-day and 365-day F10.7 index: 
c
c    INPUTS:   IYYYY (yyyy)	year 
c              IMN (mm)		month 
c	           ID (dd)		day 
c    OUTPUT:   F107D		F10.7 index for the day (adjusted 
c								to 1AU)
C              F107PD  		F10.7 index for one day prior (used in MSIS)
c              F107_81		F10.7 average over 3 solar rotations
c                               (81 days, centered on the current day) 
c              F107_365 	F10.7 12-month running mean
c              IAPDA		Daily Ap
c              ISDATE		Array-index for the specified date (for
c                                use in APF subroutine.
c 
c Using COMMON/apfa/ for indices
c
c Is used for vdrift and foeedi.
c
c If date is outside the range of indices file than F107D=F107_81=-11.1  
c-----------------------------------------------------------------------

        INTEGER		aap(23000,9),iiap(8),lm(12)
        DIMENSION 	af107(23000,3)
        LOGICAL 	mess

        common 		/iounit/konsol,mess /apfa/aap,af107,nf107

        DATA LM/31,28,31,30,31,30,31,31,30,31,30,31/

        IYBEG=1958
        if(iyyyy.lt.IYBEG) goto 21   ! APF107.DAT starts at Jan 1, 1958

        is=0
        do i=IYBEG,iyyyy-1
            nyd=365
            if(i/4*4.eq.i) nyd=366	! leap year
            IS=IS+nyd
            enddo
        lm(2)=28
        if(iyyyy/4*4.eq.iyyyy) lm(2)=29	  ! leap year
        do i=1,IMN-1
            IS=IS+LM(i)
            ENDDO
        
        IS=IS+ID
        ISDATE = IS
        if(IS.gt.nf107) goto 21

        F107D = AF107(IS,1)
        F107PD = F107D
		if(IS.gt.1) F107PD = AF107(IS-1,1)
        F107_81=AF107(IS,2)
 		if(F107_81.lt.-4.) F107_81=F107D
        F107_365=AF107(IS,3)
  		if(F107_365.lt.-4.) F107_365=F107D
        IAPDA=AAP(is,9)
        goto 20
                 
21      if(mess) write(konsol,100)
100     format(1X,'APF_ONLY: Date is outside range of F10.7D indices',
     &    ' file (F10.7D = F10.7_81 = F10.7RM12).')
        F107D = -11.1
        F107_81 = -11.1
        F107_365 = -11.1
        IAPDA = -11
    
20    RETURN
      END
C      
C
C----------------------STORM MODEL --------------------------------
C
      SUBROUTINE CONVER(rga,rgo,rgma)

C     This subroutine converts a geographic latitude and longitude
C     location to a corrected geomagnetic latitude.
C
C     INPUT: 
C       geographic latitude   -90. to +90.
C       geographic longitude  0. to 360. positive east from Greenwich.
C
C     OUTPUT:
C       corrected geomagnetic latitude	-90. to +90.


      DIMENSION CORMAG(20,91)      
      DATA ((CORMAG(i,j),i=1,20),j=1,31)/
     +163.68,163.68,163.68,163.68,163.68,163.68,
     +163.68,163.68,163.68,163.68,163.68,163.68,163.68,163.68,
     +163.68,163.68,163.68,163.68,163.68,163.68,162.60,163.12,
     +163.64,164.18,164.54,164.90,165.16,165.66,166.00,165.86,
     +165.20,164.38,163.66,162.94,162.42,162.00,161.70,161.70,
     +161.80,162.14,161.20,162.18,163.26,164.44,165.62,166.60,
     +167.42,167.80,167.38,166.82,166.00,164.66,163.26,162.16,
     +161.18,160.40,159.94,159.80,159.98,160.44,159.80,161.14,
     +162.70,164.50,166.26,167.90,169.18,169.72,169.36,168.24,
     +166.70,164.80,162.90,161.18,159.74,158.60,157.94,157.80,
     +157.98,158.72,158.40,160.10,162.02,164.28,166.64,169.00,
     +170.80,171.72,171.06,169.46,167.10,164.64,162.18,160.02,
     +158.20,156.80,156.04,155.80,156.16,157.02,157.00,158.96,
     +161.24,163.86,166.72,169.80,172.42,173.72,172.82,170.34,
     +167.30,164.22,161.34,158.74,156.60,155.00,154.08,153.90,
     +154.36,155.36,155.50,157.72,160.36,163.32,166.60,170.20,
     +173.70,175.64,174.18,170.80,167.10,163.56,160.24,157.36,
     +154.96,153.10,152.08,151.92,152.46,153.76,154.10,156.52,
     +159.36,162.52,166.24,170.30,174.62,177.48,175.04,170.82,
     +166.60,162.70,159.02,155.88,153.22,151.20,150.08,149.92,
     +150.64,152.20,152.80,155.32,158.28,161.70,165.58,170.00,
     +174.84,178.46,175.18,170.38,165.80,161.64,157.80,154.38,
     +151.52,149.30,148.18,148.02,148.92,150.60,151.40,154.08,
     +157.18,160.68,164.78,169.40,174.34,177.44,174.28,169.44,
     +164.70,160.34,156.30,152.78,149.72,147.40,146.18,146.04,
     +147.12,149.04,150.10,152.88,156.00,159.58,163.78,168.50,
     +173.28,175.60,172.86,168.14,163.40,158.98,154.88,151.10,
     +147.98,145.50,144.18,144.14,145.40,147.48,148.80,151.68,
     +154.88,158.48,162.68,167.40,171.76,173.60,171.12,166.68,
     +162.00,157.48,153.28,149.50,146.18,143.50,142.18,142.24,
     +143.68,145.98,147.50,150.54,153.68,157.28,161.42,166.10,
     +170.10,171.48,169.22,164.98,160.40,155.88,151.68,147.80,
     +144.34,141.60,140.18,140.26,141.98,144.62,146.30,149.34,
     +152.48,155.98,160.08,164.60,168.34,169.38,167.20,163.18,
     +158.60,154.18,149.98,146.02,142.54,139.70,138.18,138.46,
     +140.26,143.16,145.10,148.14,151.18,154.60,158.68,163.10,
     +166.48,167.28,165.18,161.32,156.90,152.48,148.28,144.32,
     +140.74,137.80,136.22,136.48,138.64,141.76,143.90,146.98,
     +149.98,153.30,157.24,161.40,164.52,165.16,162.86,159.42,
     +155.00,150.68,146.48,142.52,138.94,135.90,134.22,134.68,
     +137.02,140.40,142.70,145.84,148.76,151.92,155.74,159.70,
     +162.52,162.96,160.98,157.42,153.10,148.84,144.68,140.82,
     +137.20,134.00,132.32,132.80,135.42,139.10,141.60,144.74,
     +147.46,150.52,154.20,158.00,160.46,160.76,158.86,155.36,
     +151.20,146.94,142.88,139.02,135.40,132.10,130.32,131.00,
     +133.80,137.74,140.50,143.58,146.24,149.12,152.60,156.20,
     +158.40,158.66,156.76,153.36,149.30,145.04,141.08,137.30,
     +133.60,130.30,128.42,129.12,132.28,136.44,139.30,142.48,
     +144.94,147.64,150.48,154.30,156.34,156.36,154.56,151.26,
     +147.30,143.14,139.20,135.50,131.90,128.40,126.52,127.32,
     +130.76,135.18,138.20,141.28,143.72,146.24,149.26,152.40,
     +154.24,154.16,152.36,149.16,145.30,141.24,137.30,133.70,
     +130.10,126.60,124.62,125.54,129.16,133.92,137.10,140.18,
     +142.42,144.66,147.62,150.50,152.18,151.96,150.16,147.10,
     +143.30,139.24,135.50,131.90,128.36,124.80,122.72,123.74,
     +127.64,132.62,135.90,139.02,141.12,143.18,145.92,148.60,
     +149.98,149.76,148.04,145.00,141.20,137.30,133.60,130.10,
     +126.60,123.00,120.86,121.96,126.12,131.36,134.80,137.88,
     +139.80,141.68,144.08,146.60,147.88,147.56,145.84,142.90,
     +139.20,135.30,131.70,128.28,124.86,121.30,118.96,120.18,
     +124.70,130.16,133.60,136.72,138.48,140.10,142.38,144.60,
     +145.72,145.34,143.64,140.80,137.10,133.30,129.72,126.48,
     +123.10,119.50,117.16,118.48,123.18,128.86,132.40,135.42,
     +137.08,138.50,140.54,142.60,143.52,143.06,141.44,138.70,
     +135.10,131.30,127.82,124.58,121.40,117.70,115.26,116.70,
     +121.66,127.60,131.20,134.22,135.66,136.82,138.70,140.60,
     +141.36,140.86,139.24,136.50,133.00,129.30,125.92,122.78,
     +119.60,116.00,113.40,114.92,120.16,126.30,130.00,132.92,
     +134.24,135.14,136.80,138.60,139.16,138.64,137.12,134.40,
     +130.90,127.20,123.92,120.96,117.90,114.20,111.56,113.12,
     +118.64,124.90,128.70,131.56,132.74,133.44,134.90,136.50,
     +137.00,136.36,134.82,132.30,128.70,125.16,121.94,119.06,
     +116.10,112.50,109.70,111.42,117.14,123.60,127.30,130.16,
     +131.22,131.66,133.00,134.50,134.80,134.14,132.62,130.14,
     +126.60,123.06,119.94,117.16,114.30,110.70,107.80,109.64,
     +115.62,122.24,125.90,128.76,129.62,129.96,131.06,132.40,
     +132.60,131.86,130.42,128.00,124.50,120.96,117.96,115.26,
     +112.54,108.90,105.94,107.86,114.02,120.84/

      DATA ((CORMAG(i,j),i=1,20),j=32,61)/
     +124.05,126.79,
     +127.55,127.83,128.90,130.21,130.41,129.71,128.33,125.96,
     +122.49,118.96,115.97,113.26,110.52,106.89,104.01,106.00,
     +112.21,119.06,122.19,124.82,125.48,125.69,126.73,128.03,
     +128.22,127.55,126.23,123.92,120.47,116.97,113.97,111.26,
     +108.50,104.89,102.08,104.14,110.41,117.29,120.34,122.85,
     +123.40,123.56,124.57,125.84,126.03,125.40,124.14,121.88,
     +118.46,114.97,111.98,109.26,106.48,102.88,100.15,102.28,
     +108.60,115.51,118.49,120.88,121.33,121.42,122.40,123.65,
     +123.84,123.24,122.04,119.83,116.45,112.97,109.98,107.26,
     +104.46,100.87,098.22,100.42,106.79,113.74,116.63,118.91,
     +119.26,119.29,120.24,121.47,121.65,121.09,119.95,117.79,
     +114.43,110.98,107.99,105.26,102.44,098.87,096.29,098.56,
     +104.98,111.96,114.78,116.94,117.19,117.15,118.07,119.28,
     +119.46,118.93,117.86,115.75,112.42,108.98,106.00,103.26,
     +100.42,096.86,094.36,096.70,103.18,110.19,112.93,114.97,
     +115.12,115.02,115.91,117.09,117.27,116.78,115.76,113.71,
     +110.41,106.98,104.00,101.26,098.40,094.85,092.43,094.84,
     +101.37,108.41,111.07,113.00,113.04,112.88,113.74,114.91,
     +115.08,114.62,113.67,111.67,108.39,104.99,102.01,099.26,
     +096.38,092.85,090.51,092.97,099.56,106.64,109.22,111.03,
     +110.97,110.75,111.58,112.72,112.89,112.47,111.57,109.63,
     +106.38,102.99,100.01,097.26,094.36,090.84,088.58,091.11,
     +097.75,104.86,107.37,109.06,108.90,108.61,109.41,110.53,
     +110.70,110.31,109.48,107.59,104.37,100.99,098.02,095.26,
     +092.34,088.83,086.65,089.25,095.95,103.09,105.51,107.09,
     +106.83,106.48,107.25,108.35,108.51,108.16,107.39,105.55,
     +102.35,099.00,096.03,093.26,090.32,086.83,084.72,087.39,
     +094.14,101.31,103.66,105.12,104.76,104.34,105.08,106.16,
     +106.32,106.00,105.29,103.50,100.34,097.00,094.03,091.26,
     +088.30,084.82,082.79,085.53,092.33,099.54,101.81,103.15,
     +102.68,102.21,102.92,103.97,104.13,103.85,103.20,101.46,
     +098.33,095.00,092.04,089.26,086.28,082.81,080.86,083.67,
     +090.52,097.76,099.95,101.18,100.61,100.07,100.75,101.79,
     +101.94,101.69,101.10,099.42,096.31,093.01,090.04,087.26,
     +084.26,080.81,078.93,081.81,088.72,095.99,098.10,099.21,
     +098.54,097.94,098.59,099.60,099.75,099.54,099.01,097.38,
     +094.30,091.01,088.05,085.26,082.24,078.80,077.00,079.95,
     +086.91,094.21,096.25,097.24,096.47,095.81,096.43,097.41,
     +097.56,097.39,096.92,095.34,092.29,089.01,086.06,083.26,
     +080.22,076.79,075.07,078.09,085.10,092.43,094.39,095.27,
     +094.40,093.67,094.26,095.23,095.37,095.23,094.82,093.30,
     +090.27,087.02,084.06,081.26,078.20,074.79,073.14,076.23,
     +083.30,090.66,092.54,093.30,092.32,091.54,092.10,093.04,
     +093.18,093.08,092.73,091.26,088.26,085.02,082.07,079.26,
     +076.18,072.78,071.21,074.37,081.49,088.88,090.69,091.33,
     +090.25,089.40,089.93,090.85,090.99,090.92,090.63,089.21,
     +086.25,083.02,080.07,077.26,074.16,070.77,069.28,072.51,
     +079.68,087.11,088.83,089.36,088.18,087.27,087.77,088.67,
     +088.80,088.77,088.54,087.17,084.23,081.03,078.08,075.26,
     +072.14,068.77,067.35,070.65,077.87,085.33,086.98,087.39,
     +086.11,085.13,085.60,086.48,086.61,086.61,086.45,085.13,
     +082.22,079.03,076.09,073.26,070.12,066.76,065.42,068.79,
     +076.07,083.56,085.13,085.42,084.04,083.00,083.44,084.29,
     +084.42,084.46,084.35,083.09,080.21,077.03,074.09,071.26,
     +068.10,064.75,063.49,066.93,074.26,081.78,083.27,083.45,
     +081.96,080.86,081.27,082.11,082.23,082.30,082.26,081.05,
     +078.19,075.04,072.10,069.26,066.08,062.75,061.57,065.06,
     +072.45,080.01,081.42,081.48,079.89,078.73,079.11,079.92,
     +080.04,080.15,080.16,079.01,076.18,073.04,070.10,067.26,
     +064.06,060.74,059.64,063.20,070.64,078.23,079.57,079.51,
     +077.82,076.59,076.94,077.73,077.85,077.99,078.07,076.97,
     +074.17,071.04,068.11,065.26,062.04,058.73,057.71,061.34,
     +068.84,076.46,077.71,077.54,075.75,074.46,074.78,075.55,
     +075.66,075.84,075.98,074.93,072.15,069.05,066.12,063.26,
     +060.02,056.73,055.78,059.48,067.03,074.68,075.86,075.57,
     +073.68,072.32,072.61,073.36,073.47,073.68,073.88,072.88,
     +070.14,067.05,064.12,061.26,058.00,054.72,053.85,057.62,
     +065.22,072.91,074.01,073.60,071.60,070.19,070.45,071.17,
     +071.28,071.53,071.79,070.84,068.13,065.05,062.13,059.26,
     +055.98,052.71,051.92,055.76,063.41,071.13,072.15,071.63,
     +069.53,068.05,068.28,068.99,069.09,069.37,069.69,068.80,
     +066.11,063.06,060.13,057.26,053.96,050.71,049.99,053.90,
     +061.61,069.36,070.30,069.66,067.46,065.92,066.12,066.80,
     +066.90,067.22,067.60,066.76,064.10,061.06,058.14,055.26,
     +051.94,048.70,048.06,052.04,059.80,067.58/

      DATA ((CORMAG(i,j),i=1,20),j=62,91)/
     +067.70,067.06,
     +065.08,063.72,063.98,064.60,064.80,065.12,065.60,064.86,
     +062.40,059.26,056.24,053.18,049.84,046.60,046.12,050.12,
     +057.52,064.80,064.90,064.42,062.70,061.62,061.78,062.40,
     +062.60,063.04,063.58,063.00,060.60,057.46,054.42,051.18,
     +047.70,044.60,044.22,048.02,055.06,061.92,062.10,061.72,
     +060.32,059.50,059.68,060.20,060.46,060.94,061.58,061.00,
     +058.70,055.66,052.52,049.18,045.60,042.50,042.22,046.00,
     +052.60,058.98,059.20,059.18,058.12,057.32,057.48,058.00,
     +058.30,058.84,059.48,059.04,056.90,053.86,050.62,047.10,
     +043.50,040.50,040.28,043.98,050.22,056.18,056.40,056.64,
     +055.84,055.20,055.38,055.80,056.16,056.84,057.48,057.04,
     +055.10,052.06,048.70,045.10,041.40,038.40,038.28,041.88,
     +047.94,053.44,053.70,054.14,053.56,053.10,053.24,053.70,
     +054.06,054.74,055.38,055.14,053.20,050.26,046.80,043.10,
     +039.34,036.40,036.38,039.96,045.56,050.84,051.10,051.70,
     +051.36,051.00,051.14,051.50,051.96,052.64,053.38,053.08,
     +051.30,048.36,044.90,041.02,037.24,034.40,034.38,037.86,
     +043.28,048.20,048.50,049.26,049.18,048.90,049.04,049.40,
     +049.86,050.64,051.28,051.08,049.40,046.46,042.98,039.02,
     +035.14,032.40,032.48,035.72,041.00,045.70,046.00,046.96,
     +046.98,046.80,046.94,047.30,047.76,048.54,049.28,049.08,
     +047.40,044.56,041.08,037.02,033.14,030.40,030.58,033.84,
     +038.72,043.20,043.50,044.62,044.80,044.80,044.94,045.20,
     +045.76,046.54,047.18,046.98,045.50,042.66,039.08,035.02,
     +031.14,028.40,028.58,031.82,036.52,040.80,041.20,042.32,
     +042.54,042.70,042.84,043.20,043.66,044.44,045.08,044.98,
     +043.50,040.76,037.08,033.04,029.04,026.40,026.68,029.82,
     +034.34,038.40,038.80,040.12,040.60,040.70,040.84,041.10,
     +041.62,042.34,042.98,042.88,041.50,038.76,035.18,031.04,
     +027.14,024.50,024.78,027.70,032.14,036.06,036.50,037.88,
     +038.50,038.68,038.84,039.10,039.56,040.34,040.88,040.82,
     +039.40,036.76,033.18,029.12,025.14,022.50,022.88,025.90,
     +029.96,033.86,034.30,035.68,036.42,036.68,036.84,037.10,
     +037.56,038.24,038.88,038.72,037.40,034.76,031.18,027.12,
     +023.14,020.60,020.98,023.90,027.88,031.66,032.10,033.58,
     +034.32,034.68,034.84,035.10,035.56,036.24,036.78,036.62,
     +035.30,032.72,029.18,025.14,021.24,018.70,019.08,021.90,
     +025.88,029.42,029.90,031.48,032.32,032.68,032.84,033.10,
     +033.56,034.22,034.68,034.42,033.20,030.72,027.28,023.22,
     +019.34,016.80,017.24,020.00,023.78,027.32,027.70,029.38,
     +030.24,030.68,030.94,031.20,031.66,032.22,032.58,032.32,
     +031.10,028.62,025.28,021.32,017.48,015.00,015.38,018.18,
     +021.80,025.22,025.70,027.28,028.24,028.78,029.04,029.30,
     +029.66,030.22,030.50,030.22,029.00,026.62,023.30,019.42,
     +015.64,013.10,013.54,016.28,019.80,023.12,023.60,025.24,
     +026.24,026.78,027.14,027.40,027.76,028.22,028.40,028.12,
     +026.80,024.52,021.30,017.52,013.78,011.30,011.74,014.48,
     +017.90,021.12,021.60,023.24,024.34,024.88,025.24,025.50,
     +025.86,026.22,026.40,025.98,024.70,022.48,019.40,015.72,
     +012.04,009.50,009.94,012.58,016.02,019.12,019.60,021.24,
     +022.34,022.98,023.34,023.70,024.00,024.30,024.40,023.88,
     +022.60,020.48,017.52,014.00,010.34,007.80,008.18,010.88,
     +014.22,017.18,017.60,019.34,020.44,021.16,021.54,021.90,
     +022.16,022.40,022.32,021.78,020.60,018.48,015.62,012.20,
     +008.68,006.00,006.44,009.18,012.42,015.28,015.80,017.44,
     +018.54,019.26,019.74,020.10,020.30,020.50,020.32,019.72,
     +018.50,016.54,013.84,010.68,007.14,004.40,004.74,007.58,
     +010.74,013.48,014.00,015.54,016.74,017.46,017.94,018.30,
     +018.50,018.58,018.32,017.72,016.50,014.64,012.24,009.18,
     +005.84,002.90,003.30,006.16,009.14,011.84,012.30,013.78,
     +014.94,015.66,016.24,016.50,016.70,016.70,016.42,005.78,
     +014.60,012.90,010.66,007.86,004.88,001.60,001.72,004.96,
     +007.84,010.24,010.70,012.14,013.24,013.96,014.44,014.80,
     +014.90,014.88,014.52,013.92,012.80,011.30,009.28,006.94,
     +004.32,001.80,001.94,004.34,006.78,008.94,009.40,010.58,
     +011.64,012.36,012.74,013.10,013.20,013.08,012.72,012.12,
     +011.10,009.86,008.30,006.50,004.60,003.10,003.16,004.50,
     +006.20,007.90,008.40,009.42,010.14,010.76,011.14,011.40,
     +011.40,011.38,011.02,010.46,009.70,008.72,007.64,006.46,
     +005.42,004.60,004.70,005.34,006.24,007.36,007.90,008.46,
     +008.92,009.28,009.54,009.70,009.70,009.68,009.42,009.06,
     +008.60,008.08,007.56,007.02,006.56,006.30,006.30,006.52,
     +006.96,007.38,008.15,008.15,008.15,008.15,008.15,008.15,
     +008.15,008.15,008.15,008.15,008.15,008.15,008.15,008.15,
     +008.15,008.15,008.15,008.15,008.15,008.15/

C     Data Input      
      rlan = rga
      rlo = rgo      
      
C     From "normal" geographic latitude 
C     to angle from South Pole.       
      rla = rlan + 90

      IF (rlo .EQ. 360) THEN
      	rlo = 0
        END IF

C     PROXIMITY

C     coefficients of the latitudinal points		
      LA1 = (INT(rla/2)+1)
      LA2 = LA1 + 1
      if(la2.gt.91) la2=91

C     coefficients of the longitudinal points		
      LO1 = (INT(rlo/18)+1)
corr      LO2 = LO1 + 1
      LO2 = MOD(LO1,20) + 1 

C     Four points of Geomagnetic Coordinates
      gm1 = CORMAG(LO1,LA1)
      gm2 = CORMAG(LO1,LA2) 
      gm3 = CORMAG(LO2,LA1)
      gm4 = CORMAG(LO2,LA2)

C     latitudinal points		
C      X1 = ABS(rla - (INT(rla)))                        
C      X2 = 2. - X1
	  x = (rla/2.0 - (INT(rla/2.0)))

C     longitudinal points		
C      Y1 = ABS(rlo - (INT(rlo)))                        
C      Y2 = 18. - Y1
      y =(rlo/18.0 - (INT(rlo/18.0))) 

C     X AND Y VALUES
C      x = X1 / (X1 + X2)
C      y = Y1 / (Y1 + Y2)

C     INTERPOLATION
      gmla = gm1 * (1 - x) * (1 - y) + gm2 * (1 - y) * (x) + gm3 * (y)
     1 * (1 - x) + gm4 * (x) * (y)

C     OUTPUT OF THE PROGRAM
C     From corrected geomagnetic latitude from North Pole
C     to "normal"  geomagnetic latitude.       
      rgma = 90. - gmla

      END
c
c
      SUBROUTINE STORM(ap,rga,rgo,coor,rgma,ut,doy,cf)
C----------------------------------------------------------------------
C      Fortran code to obtain the foF2 storm-time correction factor at 
C      a given location and time, using the current and the 12 previous
C      ap values as input.
C
C      ap ---> (13 elements integer array). Array with the preceeding
C              13 value of the 3-hourly ap index. The 13th value
C              in the array will contain the ap at the UT of interest,
C              the 12th value will contain the 1st three hourly interval
C              preceeding the time of interest, and so on to the 1st
C              ap value at the earliest time.
C     coor --> (integer). If coor = 2, rga should contain the 
C                         geomagnetic latitude.
C                         If coor = 1, rga should contain the 
C                         geographic latitude.
C     rga ---> (real, -90 to 90) geographic or geomagnetic latitude.
C     rgo ---> (real, 0 to 360, positive east from Greenwich.)
C                           geographic longitude, only used if coor=1.
C     ut  ---> (integer, hours 00 to 23) Universal Time of interest.
C     doy ---> (integer, 1 to 366)Day of the year.
C     cf  ---> (real) The output; the storm-time correction factor used
C              to scale foF2, foF2 * cf.
C     rgma --> corrected magnetic latitude calculated from rga and rgo
C
C     This model and computer code was developed by E. Araujo-Pradere,
C     T. Fuller-Rowell and M. Condrescu, SEC, NOAA, Boulder, USA
C     Ref: 
C     T. Fuller-Rowell, E. Araujo-Pradere, and M. Condrescu, An 
C       Empirical Ionospheric Storm-Time Ionospheric Correction Model,
C       Adv. Space Res. 8, 8, 15-24, 2000.
C----------------------------------------------------------------------
C     DIMENSIONS AND COEFFICIENTS VALUES

      DIMENSION c4(20)
      DATA c4/0.00E+00,0.00E+00,0.00E+00,0.00E+00,0.00E+00,0.00E+00,
     +0.00E+00,0.00E+00,0.00E+00,0.00E+00,0.00E+00,0.00E+00,0.00E+00,
     +0.00E+00,0.00E+00,0.00E+00,0.00E+00,0.00E+00,0.00E+00,0.00E+00/

      DIMENSION c3(20)
      DATA c3/0.00E+00,0.00E+00,0.00E+00,0.00E+00,0.00E+00,-9.44E-12,
     +0.00E+00,3.04E-12,0.00E+00,9.32E-12,-1.07E-11,0.00E+00,0.00E+00,
     +0.00E+00,1.09E-11,0.00E+00,0.00E+00,0.00E+00,0.00E+00,-1.01E-11/

      DIMENSION c2(20)
      DATA c2/1.16E-08,0.00E+00,0.00E+00,-1.46E-08,0.00E+00,9.86E-08,
     +2.25E-08,-1.67E-08,-1.62E-08,-9.42E-08,1.17E-07,4.32E-08,3.97E-08,
     +3.13E-08,-8.04E-08,3.91E-08,2.58E-08,3.45E-08,4.76E-08,1.13E-07/

      DIMENSION c1(20)
      DATA c1/-9.17E-05,-1.37E-05,0.00E+00,7.14E-05,0.00E+00,-3.21E-04,
     +-1.66E-04,-4.10E-05,1.36E-04,2.29E-04,-3.89E-04,-3.08E-04,
     +-2.81E-04,-1.90E-04,4.76E-05,-2.80E-04,-2.07E-04,-2.91E-04,
     +-3.30E-04,-4.04E-04/

      DIMENSION c0(20)
      DATA c0/1.0136E+00,1.0478E+00,1.00E+00,1.0258E+00,1.00E+00,
     +1.077E+00,1.0543E+00,1.0103E+00,9.9927E-01,9.6876E-01,1.0971E+00,
     +1.0971E+00,1.0777E+00,1.1134E+00,1.0237E+00,1.0703E+00,1.0248E+00,
     +1.0945E+00,1.1622E+00,1.1393E+00/

      DIMENSION fap(36)
      DATA fap/0.,0.,0.037037037,0.074074074,0.111111111,0.148148148,
     10.185185185,0.222222222,0.259259259,0.296296296,0.333333333,
     20.37037037,0.407407407,0.444444444,0.481481481,0.518518519,
     30.555555556,0.592592593,0.62962963,0.666666667,0.703703704,
     40.740740741,0.777777778,0.814814815,0.851851852,0.888888889,
     50.925925926,0.962962963,1.,0.66666667,0.33333334,0.,0.333333,
     60.666666,1.,0.7/

      integer code(8,6)
      data code/3,4,5,4,3,2,1,2,3,2,1,2,3,4,5,4,8,7,6,7,8,9,10,9,
     *13,12,11,12,13,14,15,14,18,17,16,17,18,19,20,19,18,17,16,17,
     *18,19,20,19/

      INTEGER ape(39)
      INTEGER ap(13)
      INTEGER ut,doy,dayno,coor,s1,s2,l1,l2
      REAL rgma, rap, rga, rgo, rs, rl

C      CALLING THE PROGRAM TO CONVERT TO GEOMAGNETIC COORDINATES

       IF (coor .EQ. 1) THEN

           CALL CONVER (rga,rgo,rgma)

       ELSE IF (coor .EQ. 2) THEN
                rgma = rga

       ELSE

          WRITE (6,*)' '
          WRITE (6,*)' '
          WRITE (6,*)'   Wrong Coordinates Selection -------- >>', coor
          WRITE (6,*)' '
          GOTO 100
       ENDIF

C FROM 3-HOURLY TO HOURLY ap (New, interpolates between the three hourly ap values)

       ape(1)=ap(1)
       ape(2)=ap(1)
       ape(38)=ap(13)
       ape(39)=ap(13)

       DO k = 1,13
          i = (k * 3) - 1
          ape(i) = ap(k)
          END DO

       DO k = 1,12
          i = k * 3
          ape(i) = (ap(k)*2 + ap(k+1))/3.0
          END DO

       DO k = 2,13
          i = (k * 3) - 2
          ape(i) = (ap(k-1) + ap(k)*2)/3.0
          END DO

C     FROM 3-HOURLY TO HOURLY ap (old version without interpolation)
c      i = 1
c      DO 10 k = 1,13
c         DO j = 1,3
c            ape(i) = ap(k)
c            i = i + 1
c            END DO
c10    CONTINUE

C     TO OBTAIN THE INTEGRAL OF ap.
C     INTEGRAL OF ap

      if(ut.eq.24) ut=0
      IF (ut .EQ. 0 .OR. ut .EQ. 3 .OR. ut .EQ. 6 .OR. ut .EQ. 9 .OR.
     1ut .EQ. 12 .OR. ut .EQ. 15 .OR. ut .EQ. 18 .OR. ut .EQ. 21) THEN
          k = 1
      ELSE IF (ut .EQ. 1 .OR. ut .EQ. 4 .OR. ut .EQ. 7 .OR. ut .EQ. 10
     1.OR.ut .EQ. 13 .OR. ut .EQ. 16 .OR. ut .EQ. 19 .OR. ut .EQ. 22)
     2THEN
          k = 2
      ELSE IF (ut .EQ. 2 .OR. ut .EQ. 5 .OR. ut .EQ. 8 .OR. ut .EQ. 11
     1.OR. ut .EQ. 14 .OR. ut .EQ. 17 .OR. ut .EQ. 20 .OR. ut .EQ. 23)
     2THEN
          k = 3

      ELSE

          WRITE (6,*)' '
          WRITE (6,*)' '
          WRITE (6,*)'  Wrong Universal Time value -------- >>', ut
          WRITE (6,*)' '
          GOTO 100

      END IF

      rap = 0

      DO j = 1,36
      rap = rap + fap(j) * ape(k+j)
      END DO

      if(rap.le.200.)then
      cf=1.0
      goto 100
      end if

      if(doy.gt.366.or.doy.lt.1)then
          WRITE (6,*)' '
          WRITE (6,*)' '
          WRITE (6,*)' '
          WRITE (6,*)'      Wrong Day of Year value --- >>', doy
          WRITE (6,*)' '
          GOTO 100
      end if

      if(rgma.gt.90.0.or.rgma.lt.-90.0)then
          WRITE (6,*)' '
          WRITE (6,*)' '
          WRITE (6,*)' '
          WRITE (6,*)'   Wrong GEOMAGNETIC LATITUDE value --- >>', rgma
          WRITE (6,*)' '
          GOTO 100
      end if

c      write(6,*)rgma

      dayno=doy
      if(rgma.lt.0.0)then
      dayno=doy+172
      if(dayno.gt.365)dayno=dayno-365
      end if

      if (dayno.ge.82) rs=(dayno-82.)/45.6+1.
      if (dayno.lt.82) rs=(dayno+283.)/45.6+1.
      s1=rs
      facs=rs-s1
      s2=s1+1
      if(s2.eq.9) s2=1
c      write(6,*)s1,s2,rs

      rgma = abs(rgma)

      rl=(rgma+10.)/20.+1
      if(rl.eq.6.0)rl=5.9
      l1=rl
      facl=rl-l1
      l2=l1+1
c      write(6,*)l1,l2,rl

C     FACTORS CALCULATIONS

      if(rap.lt.300.)then
      rapf=300.
      n1=code(s1,l1)
      cf1=c4(n1)*(rapf**4)+c3(n1) * (rapf**3) + c2(n1) * (rapf**2) +
     1c1(n1) * rapf + c0(n1)
      n2=code(s1,l2)
      cf2=c4(n2)*(rapf**4)+c3(n2) * (rapf**3) + c2(n2) * (rapf**2) +
     1c1(n2) * rapf + c0(n2)
      n3=code(s2,l1)
      cf3=c4(n3)*(rapf**4)+c3(n3) * (rapf**3) + c2(n3) * (rapf**2) +
     1c1(n3) * rapf + c0(n3)
      n4=code(s2,l2)
      cf4=c4(n4)*(rapf**4)+c3(n4) * (rapf**3) + c2(n4) * (rapf**2) +
     1c1(n4) * rapf + c0(n4)

C     INTERPOLATION

      cf300=cf1*(1 - facs) * (1 - facl) + cf2 * (1 - facs) * (facl) +
     *cf3 * (facs) * (1 - facl) + cf4 * (facs) * (facl)

      cf = (cf300-1.0)*rap/100.-2.*cf300+3.
      goto 100
      end if

      n1=code(s1,l1)
c      write(6,*)n1
      cf1 = c4(n1) * (rap**4) + c3(n1) * (rap**3) + c2(n1) * (rap**2) +
     1c1(n1) * rap + c0(n1)
      n2=code(s1,l2)
      cf2 = c4(n2) * (rap**4) + c3(n2) * (rap**3) + c2(n2) * (rap**2) +
     1c1(n2) * rap + c0(n2)
      n3=code(s2,l1)
      cf3 = c4(n3) * (rap**4) + c3(n3) * (rap**3) + c2(n3) * (rap**2) +
     1c1(n3) * rap + c0(n3)
      n4=code(s2,l2)
      cf4 = c4(n4) * (rap**4) + c3(n4) * (rap**3) + c2(n4) * (rap**2) +
     1c1(n4) * rap + c0(n4)

C     INTERPOLATION

      cf = cf1 * (1 - facs) * (1 - facl) + cf2 * (1 - facs) * (facl) +
     *cf3 * (facs) * (1 - facl) + cf4 * (facs) * (facl)

100   CONTINUE

      RETURN

      END
C
C
      FUNCTION STORME_AP(JDOY,XMLAT,AP)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C EMPIRICAL STORM-E MODEL: COMPUTES A STORM-TO-QUIET RATIO (SQR) FACTOR
C TO ADJUST THE QUIESCENT E-REGION PEAK ELECTRON DENSITY TO ACCOUNT FOR
C ENHANCEMENTS DUE TO GEOMAGNETIC ACTIVITY. THE SQR FACTORS WERE
C COMPUTED FROM NO+ 4.3 UM VOLUME EMISSION RATES DERIVED FROM 
C TIMED/SABER LIMB RADIANCE MEASUREMENTS. THE SABER-DERIVED SQR FACTORS
C WERE FIT TO POWE-LAW IN THE ap INDEX.   
C
C INPUT PARAMETERS:
C
C  JDOY      --- DAY OF YEAR (1-365) 
C  XMLAT     --- MAGNETIC LATITUDE (DEGREES)
C  AP        --- ap INDEX
C
C OUTPUT PARAMETER
C 
C  STORME_AP --- STORM-TO-QUIET RATIO (SQR) TO ADJUST QUIESCENT E-REGION
C                PEAK ELECTRON DENSITY TO ACCOUNT FOR GEOMAGNETIC
C                ENHANCEMENTS. SQR COMPUTED FROM A POWER-LAW FIT
C                IN AP-INDEX: SQR=C1*AP**C2+C3
C
C REFERENCES:
C 
C  (1) Mertens et al. [submitted to JASR, 2011]
C  (2) Fernandez et al. [JASR, Vol. 46, 2010]
C  (3) Mertens et al. [Proc. of SPIE, Vol. 7475, 2009]
C  (4) Mertens et al. [Proc. of SPIE, Vol. 6745, 2007]
C  (5) Mertens et al. [JASR, Vol. 39, 2007] 
C 
C SOFTWARE WRITTEN BY Christopher J. Mertens
C                     NASA Langley Research Center
C                     Atmospheric Sciences Competency
C                     21 Langley Blvd., Mail Stop 401B
C                     Hampton, VA 23681-2199
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      PARAMETER(NMLG=37,NDBD=5)
      DIMENSION C3(NMLG,NDBD)
      DIMENSION XMLG(NMLG),IDBD(NDBD),C1(NMLG,NDBD),C2(NMLG,NDBD)
      LOGICAL mess

      COMMON /iounit/konsol,mess

      DATA XMLG/-90.0,-85.0,-80.0,-75.0,-70.0,-65.0,-60.0,-55.0,-50.0,
     &          -45.0,-40.0,-35.0,-30.0,-25.0,-20.0,-15.0,-10.0,-5.0,
     &          0.0,5.0,10.0,15.0,20.0,25.0,30.0,35.0,40.0,45.0,50.0,
     &          55.0,60.0,65.0,70.0,75.0,80.0,85.0,90.0/
      DATA IDBD/79,171,264,354,366/
C
C JDOY        | 0-79 ||80-171||172-264||265-354||355-365|
C
      DATA ((C1(IML,IDB),IDB=1,NDBD),IML=1,NMLG)
     &     / 0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-90.0 
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-85.0
     &       0.00000, 0.00508, 0.17360, 0.00000, 0.00000, !-80.0
     &       0.00000, 0.31576, 0.31498, 0.00000, 0.00000, !-75.0
     &       0.00000, 0.39217, 0.40121, 0.00000, 0.00000, !-70.0
     &       0.00000, 0.32634, 0.30179, 0.00000, 0.00000, !-65.0
     &       0.11573, 0.06211, 0.16230, 0.20233, 0.11573, !-60.0
     &       0.00526, 0.00013, 0.00204, 0.04965, 0.00526, !-55.0
     &       0.00011, 0.00013, 0.00018, 0.00040, 0.00011, !-50.0
     &       0.00001, 0.00002, 0.00040, 0.00001, 0.00001, !-45.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-40.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-35.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-30.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-25.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-20.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-15.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-10.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! -5.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !  0.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !  5.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 10.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 15.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 20.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 25.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 30.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 35.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 40.0
     &       0.00000,-0.02738, 0.00004, 0.00001, 0.00000, ! 45.0
     &       0.00001,-0.00022, 0.00001, 0.00004, 0.00001, ! 50.0
     &       0.00126, 0.00062, 0.00011, 0.00345, 0.00126, ! 55.0
     &       0.14923, 0.05483, 0.07113, 0.18282, 0.14923, ! 60.0
     &       0.37361, 0.00000, 0.00000, 0.44592, 0.37361, ! 65.0
     &       0.27792, 0.00000, 0.00000, 0.00804, 0.27792, ! 70.0
     &       0.06445, 0.00000, 0.00000, 0.10315, 0.06445, ! 75.0
     &       0.00149, 0.00000, 0.00000, 0.00073, 0.00149, ! 80.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 85.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000/ ! 90.0  
C
C JDOY        | 0-79 ||80-171||172-264||265-354||355-365|
C
      DATA ((C2(IML,IDB),IDB=1,NDBD),IML=1,NMLG)
     &     / 0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-90.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-85.0
     &       0.00000, 1.00000, 0.32415, 0.00000, 0.00000, !-80.0
     &       0.00000, 0.36538, 0.35455, 0.00000, 0.00000, !-75.0
     &       0.00000, 0.41287, 0.38062, 0.00000, 0.00000, !-70.0
     &       0.00000, 0.52224, 0.52810, 0.00000, 0.00000, !-65.0
     &       0.73025, 0.90723, 0.68107, 0.64815, 0.73025, !-60.0
     &       1.29410, 2.06038, 1.47332, 0.84843, 1.29410, !-55.0
     &       1.79442, 1.77511, 1.59906, 1.59141, 1.79442, !-50.0
     &       1.84434, 1.70607, 1.03056, 1.92168, 1.84434, !-45.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-40.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-35.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-30.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-25.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-20.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-15.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-10.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! -5.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !  0.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !  5.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 10.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 15.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 20.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 25.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 30.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 35.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 40.0
     &       2.04797, 0.27034, 1.00000, 1.90792, 2.04797, ! 45.0
     &       2.24520, 1.00000, 1.88721, 2.01535, 2.24520, ! 50.0
     &       1.56493, 1.52468, 1.93389, 1.38532, 1.56493, ! 55.0
     &       0.71442, 0.87492, 0.78890, 0.66828, 0.71442, ! 60.0
     &       0.53546, 0.00000, 0.00000, 0.42597, 0.53546, ! 65.0
     &       0.48647, 0.00000, 0.00000, 1.00000, 0.48647, ! 70.0
     &       0.67340, 0.00000, 0.00000, 0.36809, 0.67340, ! 75.0
     &       1.44025, 0.00000, 0.00000, 1.13529, 1.44025, ! 80.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 85.0
     &       0.00000, 0.00000, 0.00000, 0.00000, 0.00000/ ! 90.0 
C
C JDOY        | 0-79 ||80-171||172-264||265-354||355-365|
C
      DATA ((C3(IML,IDB),IDB=1,NDBD),IML=1,NMLG)
     &     / 1.00000, 1.00000, 1.00000, 1.00000, 1.00000, !-90.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, !-85.0
     &       1.00000, 1.03132, 0.76703, 1.00000, 1.00000, !-80.0
     &       1.00000, 0.57588, 0.56324, 1.00000, 1.00000, !-75.0
     &       1.00000, 0.41370, 0.38549, 1.00000, 1.00000, !-70.0
     &       1.00000, 0.51704, 0.50217, 1.00000, 1.00000, !-65.0
     &       0.55236, 0.80162, 0.60824, 0.46999, 0.55236, !-60.0
     &       0.90923, 0.99688, 0.96752, 0.67312, 0.90923, !-55.0
     &       0.99338, 0.98486, 0.99503, 0.87473, 0.99338, !-50.0
     &       1.00031, 1.00369, 1.00225, 0.91242, 1.00031, !-45.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, !-40.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, !-35.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, !-30.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, !-25.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, !-20.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, !-15.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, !-10.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, ! -5.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, !  0.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, !  5.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, ! 10.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, ! 15.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, ! 20.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, ! 25.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, ! 30.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, ! 35.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, ! 40.0
     &       1.04797, 1.02319, 0.98581, 1.01457, 1.04797, ! 45.0
     &       1.03332, 0.97016, 0.97807, 0.99044, 1.03332, ! 50.0
     &       1.00633, 0.94822, 0.96340, 0.95363, 1.00633, ! 55.0
     &       0.67902, 0.71540, 0.70230, 0.60821, 0.67902, ! 60.0
     &       0.35017, 1.00000, 1.00000, 0.51033, 0.35017, ! 65.0
     &       0.63358, 1.00000, 1.00000, 1.37782, 0.63358, ! 70.0
     &       0.85724, 1.00000, 1.00000, 0.91942, 0.85724, ! 75.0
     &       0.92703, 1.00000, 1.00000, 1.00502, 0.92703, ! 80.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000, ! 85.0
     &       1.00000, 1.00000, 1.00000, 1.00000, 1.00000/ ! 90.0
C
C ... Find Season-Averaged Coefficient Index 
C
      IDXS=0
      IF(JDOY.LE.IDBD(1)) IDXS=1
      DO IS=2,NDBD
        IF((JDOY.GT.IDBD(IS-1)).AND.(JDOY.LE.IDBD(IS))) IDXS=IS
      ENDDO
      IF(IDXS.EQ.0) THEN
        if(mess) WRITE(konsol,*) 'ERROR IN STORME_AP: ',
     &   'PROBLEM FINDING SEASON-AVERAGED COEFFICIENT',
     &   'DAY OF YEAR = ',JDOY
        STORME_AP=-5.0
        GOTO 222 
      ENDIF
C
C ... Find Magnetic Latitude Coefficient Index
C 
      IDXL=0
      DELG=ABS(XMLG(1)-XMLG(2))
      DELD=DELG/2.0
      YMP=XMLG(1)+DELD
      YMM=XMLG(NMLG)-DELD
      IF((XMLAT.GE.XMLG(1)).AND.(XMLAT.LE.YMP)) IDXL=1
      IF((XMLAT.GT.YMM).AND.(XMLAT.LE.XMLG(NMLG))) IDXL=NMLG
      DO IL=2,NMLG-1
        YMP=XMLG(IL)+DELD
        YMM=XMLG(IL)-DELD
        IF((XMLAT.GT.YMM).AND.(XMLAT.LE.YMP)) IDXL=IL
      ENDDO
      IF(IDXL.EQ.0) THEN
        if(mess) WRITE(konsol,*) 'ERROR IN STORME_AP: ', 
     &     'PROBLEM FINDING MAGNETIC LATITUDE COEFFICIENT',
     &     'MAGNETIC LATITUDE(DEGREES) = ',XMLAT
        STORME_AP=-5.0
        GOTO 222
      ENDIF
C
C ... COMPUTE E-REGION ELECTRON DENSITY GEOMAGNETIC STORM ENHANCEMET
C ... FACTOR (i.e., THE STORM-TO-QUIET RATIO (SQR)) 
C
      SQR=C1(IDXL,IDXS)*AP**(C2(IDXL,IDXS))+C3(IDXL,IDXS)
      IF(SQR.LT.1.0) SQR=1.0
      STORME_AP=SQR
   
222   RETURN
      END    
C
C
C****************************************************************************
C
        subroutine vdrift(xt,xl,param,y)
C-------------------------------------------------------------------
C       SUBROUTINE CALCULATES EQUATORIAL VERTICAL DRIFT AS DESCRIBED 
C       IN SCHERLIESS AND FEJER, JGR, 104, 6829-6842, 1999
C
C       INPUT:   XT: SOLAR LOCAL TIME  [h]
C                XL: GEOGRAPHIC LONGITUDE (+ EAST) [degrees]
C               
C           PARAM: 2-DIM ARRAY (DOY,F10.7CM)
C                  DOY     :Day of Year has to run from 1 to 365(366)
C                  F10.7cm : F10.7cm solar flux (daily value)
C             
C       OUTPUT:   Y: EQUATORIAL VERTICAL DRIFT [m/s]
C
C-------------------------------------------------------------------
c        IMPLICIT REAL*8 (A-H,O-Z)
        IMPLICIT REAL (A-H,O-Z)
       
c        real*8 param(2),coeff(624),coeff1(594),coeff2(30),funct(6)
c        real*8 xt,xl,y
c        real*8 bspl4,bspl4_time,bspl4_long

        real param(2),coeff(624),coeff1(594),coeff2(30),funct(6)
        real xt,xl,y
        real bspl4,bspl4_time,bspl4_long

        integer i,j,ind,il,kk
        integer index_t,dim_t,index_l,dim_l,index,dim,nfunc
        
        data index_t/13/,dim_t/78/,index_l/8/,dim_l/48/,index/104/,
     *   dim/624/,nfunc/6/

        data coeff1/
     *  -10.80592, -9.63722,-11.52666, -0.05716, -0.06288,  0.03564,
     *   -5.80962, -7.86988, -8.50888, -0.05194, -0.05798, -0.00138,
     *    2.09876,-19.99896, -5.11393, -0.05370, -0.06585,  0.03171,
     *  -10.22653, -3.62499,-14.85924, -0.04023, -0.01190, -0.09656,
     *   -4.85180,-26.26264, -6.20501, -0.05342, -0.05174,  0.02419,
     *  -13.98936,-18.10416, -9.30503, -0.01969, -0.03132, -0.01984,
     *  -18.36633,-24.44898,-16.69001,  0.02033, -0.03414, -0.02062,
     *  -20.27621,-16.95623,-36.58234,  0.01445, -0.02044, -0.08297,
     *    1.44450,  5.53004,  4.55166, -0.02356, -0.04267,  0.05023,
     *    5.50589,  7.05381,  1.94387, -0.03147, -0.03548,  0.01166,
     *    3.24165, 10.05002,  4.26218, -0.03419, -0.02651,  0.07456,
     *    7.02218,  0.06708,-11.31012, -0.03252, -0.01021, -0.09008,
     *   -3.47588, -2.82534, -4.17668, -0.03719, -0.01519,  0.06507,
     *   -4.02607,-11.19563,-10.52923, -0.00592, -0.01286, -0.00477,
     *  -11.47478, -9.57758,-10.36887,  0.04555, -0.02249,  0.00528,
     *  -14.19283,  7.86422, -8.76821,  0.05758, -0.02398, -0.04075,
     *   14.58890, 36.63322, 27.57497,  0.01358, -0.02316,  0.04723,
     *   12.53122, 29.38367, 21.40356, -0.00071, -0.00553,  0.01484,
     *   18.64421, 26.27327, 18.32704,  0.00578,  0.03349,  0.11249,
     *    4.53014,  6.15099,  7.41935, -0.02860, -0.00395, -0.08394,
     *   14.29422,  9.77569,  2.85689, -0.00107,  0.04263,  0.10739,
     *    7.17246,  4.40242, -1.00794,  0.00089,  0.01436,  0.00626,
     *    7.75487,  5.01928,  4.36908,  0.03952, -0.00614,  0.03039,
     *   10.25556,  8.82631, 24.21745,  0.05492, -0.02968,  0.00177,
     *   21.86648, 24.03218, 39.82008,  0.00490, -0.01281, -0.01715,
     *   19.18547, 23.97403, 34.44242,  0.01978,  0.01564, -0.02434,
     *   26.30614, 14.22662, 31.16844,  0.06495,  0.19590,  0.05631,
     *   21.09354, 25.56253, 29.91629, -0.04397, -0.08079, -0.07903,
     *   28.30202, 16.80567, 38.63945,  0.05864,  0.16407,  0.07622,
     *   22.68528, 25.91119, 40.45979, -0.03185, -0.01039, -0.01206,
     *   31.98703, 24.46271, 38.13028, -0.08738, -0.00280,  0.01322,
     *   46.67387, 16.80171, 22.77190, -0.13643, -0.05277, -0.01982,
     *   13.87476, 20.52521,  5.22899,  0.00485, -0.04357,  0.09970,
     *   21.46928, 13.55871, 10.23772, -0.04457,  0.01307,  0.06589,
     *   16.18181, 16.02960,  9.28661, -0.01225,  0.14623, -0.01570,
     *   18.16289, -1.58230, 14.54986, -0.00375, -0.00087,  0.04991,
     *   10.00292, 11.82653,  0.44417, -0.00768,  0.15940, -0.01775,
     *   12.15362,  5.65843, -1.94855, -0.00689,  0.03851,  0.04851,
     *   -1.25167,  9.05439,  0.74164,  0.01065,  0.03153,  0.02433,
     *  -15.46799, 18.23132, 27.45320,  0.00899, -0.00017,  0.03385,
     *    2.70396, -0.87077,  6.11476, -0.00081,  0.05167, -0.08932,
     *    3.21321, -1.06622,  5.43623,  0.01942,  0.05449, -0.03084,
     *   17.79267, -3.44694,  7.10702,  0.04734, -0.00945,  0.11516,
     *    0.46435,  6.78467,  4.27231, -0.02122,  0.10922, -0.03331,
     *   15.31708,  1.70927,  7.99584,  0.07462,  0.07515,  0.08934,
     *    4.19893,  6.01231,  8.04861,  0.04023,  0.14767, -0.04308,
     *    9.97541,  5.99412,  5.93588,  0.06611,  0.12144, -0.02124,
     *   13.02837, 10.29950, -4.86200,  0.04521,  0.10715, -0.05465,
     *    5.26779,  7.09019,  1.76617,  0.09339,  0.22256,  0.09222,
     *    9.17810,  5.27558,  5.45022,  0.14749,  0.11616,  0.10418,
     *    9.26391,  4.19982, 12.66250,  0.11334,  0.02532,  0.18919,
     *   13.18695,  6.06564, 11.87835,  0.26347,  0.02858,  0.14801,
     *   10.08476,  6.14899, 17.62618,  0.09331,  0.08832,  0.28208,
     *   10.75302,  7.09244, 13.90643,  0.09556,  0.16652,  0.22751,
     *    6.70338, 11.97698, 18.51413,  0.15873,  0.18936,  0.15705,
     *    5.68102, 23.81606, 20.65174,  0.19930,  0.15645,  0.08151,
     *   29.61644,  5.49433, 48.90934,  0.70710,  0.40791,  0.26325,
     *   17.11994, 19.65380, 44.88810,  0.45510,  0.41689,  0.22398,
     *    8.45700, 34.54442, 27.25364,  0.40867,  0.37223,  0.22374,
     *   -2.30305, 32.00660, 47.75799,  0.02178,  0.43626,  0.30187,
     *    8.98134, 33.01820, 33.09674,  0.33703,  0.33242,  0.41156,
     *   14.27619, 20.70858, 50.10005,  0.30115,  0.32570,  0.45061,
     *   14.44685, 16.14272, 45.40065,  0.37552,  0.31419,  0.30129,
     *    6.19718, 18.89559, 28.24927,  0.08864,  0.41627,  0.19993,
     *    7.70847, -2.36281,-21.41381,  0.13766,  0.05113, -0.11631,
     *   -9.07236,  3.76797,-20.49962,  0.03343,  0.08630,  0.00188,
     *   -8.58113,  5.06009, -6.23262,  0.04967,  0.03334,  0.24214,
     *  -27.85742,  8.34615,-27.72532, -0.08935,  0.15905, -0.03655,
     *    2.77234,  0.14626, -4.01786,  0.22338, -0.04478,  0.18650,
     *    5.61364, -3.82235,-16.72282,  0.26456, -0.03119, -0.08376,
     *   13.35847, -6.11518,-16.50327,  0.28957, -0.01345, -0.19223,
     *   -5.37290, -0.09562,-27.27889,  0.00266,  0.22823, -0.35585,
     *  -15.29676,-18.36622,-24.62948, -0.31299, -0.23832, -0.08463,
     *  -23.37099,-13.69954,-26.71177, -0.19654, -0.18522, -0.20679,
     *  -26.33762,-15.96657,-42.51953, -0.13575, -0.00329, -0.28355,
     *  -25.42140,-14.14291,-21.91748, -0.20960, -0.19176, -0.32593,
     *  -23.36042,-23.89895,-46.05270, -0.10336,  0.03030, -0.21839,
     *  -19.46259,-21.27918,-32.38143, -0.17673, -0.15484, -0.11226,
     *  -19.06169,-21.13240,-34.01677, -0.25497, -0.16878, -0.11004,
     *  -18.39463,-16.11516,-19.55804, -0.19834, -0.23271, -0.25699,
     *  -19.93482,-17.56433,-18.58818,  0.06508, -0.18075,  0.02796,
     *  -23.64078,-18.77269,-22.77715, -0.02456, -0.12238,  0.02959,
     *  -12.44508,-21.06941,-19.36011,  0.02746, -0.16329,  0.19792,
     *  -26.34187,-19.78854,-24.06651, -0.07299, -0.03082, -0.03535,
     *  -10.71667,-26.04401,-16.59048,  0.02850, -0.09680,  0.15143,
     *  -18.40481,-23.37770,-16.31450, -0.03989, -0.00729, -0.01688,
     *   -9.68886,-20.59304,-18.46657,  0.01092, -0.07901,  0.03422,
     *   -0.06685,-19.24590,-29.35494,  0.12265, -0.24792,  0.05978,
     *  -15.32341, -9.07320,-13.76101, -0.17018, -0.15122, -0.06144,
     *  -14.68939,-14.82251,-13.65846, -0.11173, -0.14410, -0.07133,
     *  -18.38628,-18.94631,-19.00893, -0.08062, -0.14481, -0.12949,
     *  -16.15328,-17.40999,-14.08705, -0.08485, -0.06896, -0.11583,
     *  -14.50295,-16.91671,-25.25793, -0.06814, -0.13727, -0.12213,
     *  -10.92188,-14.10852,-24.43877, -0.09375, -0.11638, -0.09053,
     *  -11.64716,-14.92020,-19.99063, -0.14792, -0.08681, -0.12085,
     *  -24.09766,-16.14519, -8.05683, -0.24065, -0.05877, -0.23726,
     *  -25.18396,-15.02034,-15.50531, -0.12236, -0.09610, -0.00529,
     *  -15.27905,-19.36708,-12.94046, -0.08571, -0.09560, -0.03544,
     *   -7.48927,-16.00753,-13.02842, -0.07862, -0.10110, -0.05807/
        data coeff2/
     *  -13.06383,-27.98698,-18.80004, -0.05875, -0.03737, -0.11214,
     *  -13.67370,-16.44925,-16.12632, -0.07228, -0.09322, -0.05652,
     *  -22.61245,-21.24717,-18.09933, -0.05197, -0.07477, -0.05235,
     *  -27.09189,-21.85181,-20.34676, -0.05123, -0.05683, -0.07214,
     *  -27.09561,-22.76383,-25.41151, -0.10272, -0.02058, -0.16720/

        do i=1,594 
        	coeff(i)=coeff1(i)
        	enddo
        do i=1,30 
        	coeff(i+594)=coeff2(i)
        	enddo

        call g(param,funct,xl)

        y=0.

        do i=1,index_t
          do il=1,index_l
            kk=index_l*(i-1)+il
            do j=1,nfunc
               ind=nfunc*(kk-1)+j
               bspl4=bspl4_time(i,xt)*bspl4_long(il,xl)
               y=y+bspl4*funct(j)*coeff(ind)
            end do
          end do
        end do

       end
C
C
c        real*8 function bspl4_time(i,x1)
        real function bspl4_time(i,x1)
c       *************************************************
c        implicit REAL*8 (A-H,O-Z)
        implicit REAL (A-H,O-Z)
		 
        integer i,order,j,k
c        real*8 t_t(0:39)
c        real*8 x,b(20,20),x1
        real t_t(0:39)
        real x,b(20,20),x1

        data t_t/
     *          0.00,2.75,4.75,5.50,6.25,
     *          7.25,10.00,14.00,17.25,18.00,
     *          18.75,19.75,21.00,24.00,26.75,
     *          28.75,29.50,30.25,31.25,34.00,
     *          38.00,41.25,42.00,42.75,43.75,
     *          45.00,48.00,50.75,52.75,53.50,
     *          54.25,55.25,58.00,62.00,65.25,
     *          66.00,66.75,67.75,69.00,72.00/

        order=4
        x=x1
        if(i.ge.0) then
          if (x.lt.t_t(i-0)) then
              x=x+24
              end if
          end if
        do j=i,i+order-1
           if(x.ge.t_t(j).and.x.lt.t_t(j+1)) then
               b(j,1)=1
           else
	           b(j,1)=0
           end if
        end do

        do j=2,order
          do k=i,i+order-j
            b(k,j)=(x-t_t(k))/(t_t(k+j-1)-t_t(k))*b(k,j-1)
            b(k,j)=b(k,j)+(t_t(k+j)-x)/(t_t(k+j)-t_t(k+1))*
     &                b(k+1,j-1)
          end do
        end do

        bspl4_time=b(i,order)
        end
C
C
        real function bspl4_long(i,x1)
c        real*8 function bspl4_long(i,x1)
c       *************************************************
c       implicit real*8 (A-H,O-Z) 
       implicit real (A-H,O-Z) 

        integer i,order,j,k
c        real*8 t_l(0:24)
c        real*8 x,b(20,20),x1
        real t_l(0:24)
        real x,b(20,20),x1

        data t_l/
     *          0,10,100,190,200,250,280,310,
     *          360,370,460,550,560,610,640,670,
     *          720,730,820,910,920,970,1000,1030,1080/
       
        order=4
        x=x1
        if(i.ge.0) then
          if (x.lt.t_l(i-0)) then
              x=x+360
              end if
          end if
        do j=i,i+order-1
           if(x.ge.t_l(j).and.x.lt.t_l(j+1)) then
              b(j,1)=1
           else
              b(j,1)=0
           end if
        end do

        do j=2,order
          do k=i,i+order-j
             b(k,j)=(x-t_l(k))/(t_l(k+j-1)-t_l(k))*b(k,j-1)
             b(k,j)=b(k,j)+(t_l(k+j)-x)/(t_l(k+j)-t_l(k+1))*
     &                 b(k+1,j-1)
          end do
        end do

        bspl4_long=b(i,order)
        end
C
C
        subroutine g(param,funct,x)
c       *************************************************
c        implicit real*8 (A-H,O-Z)
        implicit real (A-H,O-Z)

        integer i
c        real*8 param(2),funct(6)
c        real*8 x,a,sigma,gauss,flux,cflux
        real param(2),funct(6)
        real x,a,sigma,gauss,flux,cflux

c       *************************************************
        flux=param(2)
        if(param(2).le.75)  flux=75.
        if(param(2).ge.230) flux=230.
        cflux=flux

        a=0.
        if((param(1).ge.120).and.(param(1).le.240)) a=170.
        if((param(1).ge.120).and.(param(1).le.240)) sigma=60
        if((param(1).le.60).or.(param(1).ge.300)) a=170.
        if((param(1).le.60).or.(param(1).ge.300)) sigma=40

        if((flux.le.95).and.(a.ne.0)) then
           gauss=exp(-0.5*((x-a)**2)/sigma**2)
           cflux=gauss*95.+(1-gauss)*flux
           end if
c       *************************************************

c       *************************************************
        do i=1,6
         funct(i)=0.
        end do
c       *************************************************

c       *************************************************
        if((param(1).ge.135).and.(param(1).le.230)) funct(1)=1
        if((param(1).le.45).or.(param(1).ge.320)) funct(2)=1
        if((param(1).gt.75).and.(param(1).lt.105)) funct(3)=1
        if((param(1).gt.260).and.(param(1).lt.290)) funct(3)=1
c       *************************************************

        if((param(1).ge.45).and.(param(1).le.75)) then  ! W-E
            funct(2)=1.-(param(1)-45.)/30.
            funct(3)=1-funct(2)
            end if
        if((param(1).ge.105).and.(param(1).le.135)) then  ! E-S
            funct(3)=1.-(param(1)-105.)/30.
            funct(1)=1-funct(3)
            end if
        if((param(1).ge.230).and.(param(1).le.260)) then  ! S-E
            funct(1)=1.-(param(1)-230.)/30.
            funct(3)=1-funct(1)
            end if
        if((param(1).ge.290).and.(param(1).le.320)) then  ! E-W
            funct(3)=1.-(param(1)-290.)/30.
            funct(2)=1-funct(3)
            end if

c       *************************************************
        funct(4)=(cflux-140)*funct(1)
        funct(5)=(cflux-140)*funct(2)
        funct(6)=(flux-140)*funct(3)
c       *************************************************

        end
c
c
       SUBROUTINE StormVd(FLAG,iP,AE,SLT,PromptVd,DynamoVd,Vd)
C *******************************************************************
C  Empirical vertical disturbance drifts model
C  After Fejer and Scherliess, JGR, 102, 24047-24056,1997
C*********************************************************************
C  INPUT:
C    AE: AE(in nT) in 1 hour or 15 minute resolution;
C    SLT: Local time(in hrs) for wanted Vd;
C  OUTPUT:
C    PromptVd: Prompt penetration vertical drifts at given conditions;
C    DynamoVd: Disturbane dynamo vertical drifts at given conditions;
C    Vd: PromptVd+DynamoVd;
C*********************************************************************

c       IMPLICIT REAL*8(A-H,O-Z)
       IMPLICIT REAL(A-H,O-Z)
c       REAL*8 AE(1:366*24*4),Coff1(1:5,1:9),Coff15(1:6,1:9)
       REAL AE(1:366*24*4),Coff1(1:5,1:9),Coff15(1:6,1:9)
       INTEGER FLAG 
       DATA Coff1/
     @           0.0124,-0.0168,-0.0152,-0.0174,-0.0704,
     @          -0.0090,-0.0022,-0.0107, 0.0152,-0.0674,
     @           0.0275, 0.0051,-0.0132, 0.0020,-0.0110,
     @          -0.0022, 0.0044, 0.0095, 0.0036,-0.0206,
     @           0.0162, 0.0007, 0.0085,-0.0140, 0.0583,
     @           0.0181, 0.0185,-0.0109,-0.0031,-0.0427,
     @          -0.0057, 0.0002, 0.0086, 0.0149, 0.2637,
     @          -0.0193, 0.0035, 0.0117, 0.0099, 0.3002,
     @          -0.0492,-0.0201, 0.0338, 0.0099, 0.0746/

	 DATA Coff15/
     @	        0.0177, 0.0118,-0.0006,-0.0152,-0.0174,-0.0704,
     @	        0.0051,-0.0074,-0.0096,-0.0107, 0.0152,-0.0674,
     @	        0.0241, 0.0183, 0.0122,-0.0132, 0.0020,-0.0110,
     @	        0.0019,-0.0010, 0.0001, 0.0095, 0.0036,-0.0206,
     @	        0.0170, 0.0183, 0.0042, 0.0085,-0.0140, 0.0583,
     @          0.0086, 0.0189, 0.0200,-0.0109,-0.0031,-0.0427,
     @	       -0.0070,-0.0053,-0.0090, 0.0086, 0.0149, 0.2637,
     @	       -0.0326,-0.0101, 0.0076, 0.0117, 0.0099, 0.3002,
     @	       -0.0470,-0.0455,-0.0274, 0.0338, 0.0099, 0.0746/

CCCCCCCCCCCCCCCCC**Define to variables**CCCCCCCCCCCCCCCCCCCCC
C To 1 h time resolution:
C dAEt_30=AE(t)-AE(t-1 hour);
C dAEt_90=AE(t-1 hour)-AE(t-2 hour);
CC
C To 15 MIN time resolution :
C dAEt_7P5=AE(t)-AE(t-15min);
C dAEt_30=AE(t-15)-AE(t-45min);
C dAEt_75=AE(t-45)-AE(t-105min);
CC
C  Following variables are the same to two resolution: 
C AE1_6=average(AE(1-6hours));
C AE7_12=average(AE(7-12hours));
C AE1_12=average(AE(1-12hours));
C AEd1_6=average(X(AE(1-6hours)-130 nT));
C AEd7_12=average(X(AE(7-12hours)-130 nT));
C AEd1_12=average(X(AE(1-12hours)-130 nT));
C AEd22_28=average(X(AE(22-28hours)-130 nT));
C Here X(a)=a, a>0; =0, a<=0;
C Alfa=0,            AE1_6<200 nT;
C      AE1_6/100-2, 200 nT<AE1_6<200 nT;
C      1,            AE1_6>300 nT;
C Beta=exp(-AE1_12/90),  AE1_12>=70nT;
C      0.46,              AE1_12<70 nT;
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCccccccc
C*****************************************************
CC        FLAG>0--> 1 h time resolution
C**************************************************** 

       IF (FLAG.GT.0) THEN
C 
         dAEt_30=AE(iP)-AE(iP-1)
         dAEt_90=AE(iP-1)-AE(iP-2)
C
         AE1_6=0.0D0
         AEd1_6=0.0D0

         DO i=-1,-6,-1
             AE1_6=AE1_6+AE(iP+i)
             AEd1_6S=AE(iP+i)-130.0D0
             IF (AEd1_6S.LE.0.0D0) AEd1_6S=0.0D0
             AEd1_6=AEd1_6+AEd1_6S
         END DO

         AE1_6=AE1_6/6.0D0
         AEd1_6=AEd1_6/6.0D0
C
         AEd7_12=0.0D0

         DO i=-7,-12,-1
            AEd7_12S=AE(iP+i)-130.0D0
            IF (AEd7_12S.LE.0.0D0) AE7_12S=0.0D0
            AEd7_12=AEd7_12+AEd7_12S
         END DO

         AEd7_12=AEd7_12/6.0D0
C
         AE1_12=0.0D0

         DO i=-1,-12,-1
            AE1_12=AE1_12+AE(iP+i)
         END DO

         AE1_12=AE1_12/12.0D0
C
         AEd22_28=0.0D0

         DO i=-22,-28,-1
            AEd22_28S=AE(iP+i)-130.0D0
            IF (AED22_28S.LE.0.0D0) AEd22_28S=0.0D0
            AEd22_28=AEd22_28+AEd22_28S 
         END DO

         AEd22_28=AEd22_28/7.0D0
         AEd22_28P=AEd22_28-200.0D0
         IF (AEd22_28P.LE.0.0D0) AEd22_28P=0.0D0
CC
         IF (AE1_6.GT.300.0D0) THEN  
           Alfa=1.0D0
         ELSE IF (AE1_6.GT.200.0D0) THEN
           ALfa=AE1_6/100.0D0-2.0D0
         ELSE 
           ALfa=0.0D0
         ENDIF
CC
         IF (AE1_12.GE.70.0D0) THEN
            Beta=dexp(-AE1_12/90.0D0)
         ELSE
            Beta=0.46D0
         END IF
         PromptVd=0.0D0
         DO J=1,9
            PromptVd=PromptVd +(Coff1(1,J)*dAEt_30 +Coff1(2,J)*dAEt_90
     #                         )*bspl4_ptime(J,SLT)
         END DO
         DynamoVd=0.0D0
         DO J=1,9
            DynamoVd=DynamoVd+
     #               (Coff1(3,J)*AEd1_6+Coff1(4,J)*Alfa*AEd7_12
     #                +Coff1(5,J)*Beta*AEd22_28P)*bspl4_ptime(J,SLT)
         END DO
         Vd=PromptVd+DynamoVd
         RETURN

C 1 h time resolution end;
C********************************************************************
C                  15 min time resolution
C********************************************************************

       ELSE
         dAEt_7P5=AE(iP)-AE(iP-1)
         dAEt_30=AE(iP-1)-AE(iP-3)
         dAEt_75=AE(iP-3)-AE(iP-7)

         AE1_6=0.0D0
         AEd1_6=0.0D0

         DO i=-4,-24,-1
           AE1_6=AE1_6+AE(iP+i)
           AEd1_6s=AE(iP+i)-130.
           IF (AEd1_6s.LE.0.0) AEd1_6s=0.0
           AEd1_6=AEd1_6+AEd1_6S
         ENDDO

         AE1_6=AE1_6/21.0D0
         AEd1_6=AEd1_6/21.0D0
CC
         AEd7_12=0.0D0 
         DO i=-28,-48,-1
            AEd7_12s=AE(iP+i)-130.0
            IF (AEd7_12s.LE.0) AEd7_12s=0.0
            AEd7_12=AEd7_12+AEd7_12S
         ENDDO
         AEd7_12=AEd7_12/21.0D0
CC
         AE1_12=0.0D0
         DO i=-4,-48,-1
            AE1_12=AE1_12+AE(iP+i)
         END DO
         AE1_12=AE1_12/45.0D0
CC 
	  AEd22_28=0.0D0
          DO i=-88,-112,-1
             AEd22_28s=AE(iP+i)-130.
             IF (AEd22_28s.LE.0) AEd22_28s=0.0
	     AEd22_28=AEd22_28+AEd22_28s
	  ENDDO
          AEd22_28=AEd22_28/25.0D0
	  AEd22_28P=AEd22_28-200.0D0
	  IF (AEd22_28P.LE.0.0D0) AEd22_28P=0.0D0

c         AE1_6=0.0D0
c         AEd1_6=0.0D0
c         AEd7_12=0.0D0 
c         AEd22_28P=0.0D0
c         AE1_12=0.0D0
c         dAEt_7P5=400.D0
c         dAEt_30=0.D0
c         dAEt_75=0.D0
CC
  	  IF (AE1_6.GT.300.0D0) THEN  
             Alfa=1.0D0
          ELSE IF (AE1_6.GT.200.0D0) THEN
             ALfa=AE1_6/100.0D0-2.0D0
          ELSE 
             ALfa=0.0D0
          ENDIF
CC
          IF (AE1_12.GE.70.0D0) THEN
             Beta=dexp(-AE1_12/90.0D0)
          ELSE
             Beta=0.46D0
          END IF
CC
          PromptVd=0.0D0
          DO J=1,9
            PromptVd=PromptVd+(Coff15(1,J)*dAEt_7P5+Coff15(2,J)*dAEt_30
     #                      +Coff15(3,J)*dAEt_75)*bspl4_ptime(J,SLT)
          END DO
          DynamoVd=0.0D0
          DO J=1,9
             DynamoVd=DynamoVd +(Coff15(4,J)*AEd1_6+
     #                           Coff15(5,J)*Alfa*AEd7_12+
     #                           Coff15(6,J)*Beta*AEd22_28P
     #                          )*bspl4_ptime(J,SLT)
          END DO
          Vd=PromptVd+DynamoVd
       ENDIF
       RETURN
       END                     
C
C
       real function bspl4_ptime(i,x1)
c       real*8 function bspl4_ptime(i,x1)
C *************************************************

c       IMPLICIT REAL*8 (A-H,O-Z)
       IMPLICIT REAL (A-H,O-Z)

       integer i,order,j,k
c       real*8 t_t(0:27)
c       real*8 x,b(20,20),x1
       real t_t(0:27)
       real x,b(20,20),x1

       data t_t/0.00,3.00,4.50,6.00,9.00,12.0,15.0,18.0,21.0,
     *          24.0,27.0,28.5,30.0,33.0,36.0,39.0,42.0,45.0,
     *          48.0,51.0,52.5,54.0,57.0,60.0,63.0,66.0,69.0,72.0/
C
       order=4
       x=x1
       if(i.ge.0) then
          if (x.lt.t_t(i-0)) then
	       x=x+24
          end if
       end if
       do j=i,i+order-1
	   if(x.ge.t_t(j).and.x.lt.t_t(j+1)) then
	       b(j,1)=1
	   else
	       b(j,1)=0
	   end if
       end do
c
       do j=2,order
          do k=i,i+order-j
             b(k,j)=(x-t_t(k))/(t_t(k+j-1)-t_t(k))*b(k,j-1)
             b(k,j)=b(k,j)+(t_t(k+j)-x)/(t_t(k+j)-t_t(k+1))*b(k+1,j-1)
          end do
       end do
       bspl4_ptime=b(i,order)
       return
       end

C
C***************************************************************************
C

       subroutine spreadf_brazil(idoy,idiy,f107,geolat,osfbr)
**********************************************************************       
*
*       SUBROUTINE CALCULATES PERCENTAGE OF SPREAD F OCCURRENCE OVER 
*       BRAZILIAN SECTOR AS DESCRIBED IN:
*       ABDU ET AL., Advances in Space Research, 31(3), 
*       703-716, 2003
*
*    INPUT:
*         IDOY: DAY OF YEAR (1 TO 365/366)
*         IDIY: DAYS IN YEAR (365 OR 366)
*         F107: F10.7 cm SOLAR FLUX (DAILY VALUE)
*         GEOLAT: BRAZILIAN GEOGRAPHIC LATITUDE BETWEEN -4 AND -22.5
*
*    OUTPUT:         
*         OSFBR(25): PERCENTAGE OF SPREAD F OCCURRENCE FOR 25 TIME 
*                    STEPS FROM LT=18 TO LT=7 ON THE NEXT DAY IN
*                    STEPS OF 0.5 HOURS.
*
**********************************************************************
*
         dimension param(3),osfbr(25),coef_sfa(684),coef_sfb(684),
     &             sosf(2,32,3,12)
         common/mflux/kf,n     
         data coef_sfa/
     *   0.07,0.13,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.05,0.04,0.03
     *  ,0.06,0.07,0.02,0.03,0.03,0.07,0.06,0.07,0.21,0.28,0.34,0.16
     *  ,0.12,0.00,0.02,0.02,0.04,0.05,0.02,0.11,0.19,0.31,0.31,0.11
     *  ,0.14,0.16,0.03,0.00,0.00,0.02,0.00,0.00,0.05,0.55,0.61,0.28
     *  ,0.26,0.10,0.15,0.23,0.07,0.06,0.03,0.03,0.41,0.88,0.89,0.65
     *  ,0.19,0.18,0.17,0.10,0.14,0.15,0.03,0.14,0.46,0.72,0.71,0.53
     *  ,0.57,0.38,0.30,0.14,0.00,0.04,0.03,0.02,0.21,0.84,0.87,0.72
     *  ,0.79,0.60,0.65,0.70,0.29,0.19,0.19,0.32,0.73,0.96,0.99,0.84
     *  ,0.75,0.78,0.79,0.70,0.63,0.24,0.28,0.53,0.75,0.77,0.75,0.85
     *  ,0.78,0.51,0.59,0.24,0.00,0.07,0.05,0.06,0.33,0.92,0.96,0.89
     *  ,0.90,0.84,0.86,0.81,0.33,0.27,0.23,0.47,0.90,1.00,1.00,0.96
     *  ,0.96,0.89,0.92,0.84,0.80,0.27,0.35,0.61,0.81,0.93,0.86,0.97
     *  ,0.84,0.65,0.75,0.25,0.00,0.04,0.08,0.06,0.53,0.93,0.96,0.94
     *  ,0.95,0.84,0.91,0.71,0.18,0.17,0.21,0.42,0.92,0.99,0.97,0.92
     *  ,0.92,0.93,0.92,0.67,0.58,0.21,0.38,0.55,0.83,0.90,0.89,0.97
     *  ,0.84,0.71,0.91,0.21,0.02,0.07,0.03,0.03,0.60,0.95,0.96,0.92
     *  ,0.97,0.91,0.92,0.67,0.11,0.08,0.09,0.23,0.90,0.99,0.99,0.96
     *  ,0.96,0.93,0.98,0.63,0.25,0.08,0.12,0.41,0.79,0.95,0.98,0.99
     *  ,0.86,0.80,0.94,0.22,0.02,0.04,0.03,0.03,0.63,0.95,0.96,0.94
     *  ,0.98,0.90,0.91,0.59,0.10,0.04,0.07,0.15,0.83,0.97,0.97,0.90
     *  ,0.92,0.93,0.95,0.57,0.12,0.03,0.05,0.23,0.74,0.94,0.94,0.99
     *  ,0.84,0.84,0.90,0.24,0.02,0.07,0.07,0.03,0.60,0.95,0.96,0.97
     *  ,0.93,0.82,0.83,0.51,0.08,0.07,0.09,0.09,0.71,0.95,0.92,0.87
     *  ,0.91,0.91,0.89,0.50,0.14,0.03,0.06,0.14,0.61,0.84,0.89,0.94
     *  ,0.77,0.82,0.84,0.34,0.10,0.11,0.12,0.06,0.43,0.87,0.94,0.97
     *  ,0.91,0.77,0.68,0.42,0.06,0.08,0.10,0.04,0.51,0.78,0.71,0.77
     *  ,0.85,0.88,0.77,0.35,0.16,0.05,0.08,0.15,0.53,0.70,0.60,0.89
     *  ,0.85,0.71,0.72,0.26,0.16,0.17,0.08,0.15,0.38,0.73,0.91,0.91
     *  ,0.89,0.68,0.53,0.26,0.06,0.12,0.08,0.09,0.32,0.63,0.67,0.77
     *  ,0.81,0.79,0.59,0.21,0.14,0.03,0.06,0.09,0.23,0.51,0.34,0.79
     *  ,0.88,0.66,0.59,0.16,0.18,0.15,0.16,0.16,0.33,0.67,0.75,0.88
     *  ,0.80,0.64,0.52,0.16,0.04,0.09,0.04,0.09,0.24,0.47,0.53,0.50
     *  ,0.73,0.69,0.48,0.11,0.14,0.03,0.03,0.03,0.20,0.37,0.28,0.54
     *  ,0.81,0.64,0.49,0.18,0.12,0.17,0.16,0.19,0.31,0.57,0.70,0.83
     *  ,0.76,0.57,0.52,0.13,0.04,0.06,0.05,0.08,0.21,0.49,0.47,0.39
     *  ,0.69,0.66,0.43,0.11,0.10,0.02,0.00,0.03,0.16,0.39,0.24,0.35
     *  ,0.77,0.45,0.39,0.10,0.10,0.13,0.15,0.18,0.29,0.57,0.70,0.69
     *  ,0.71,0.49,0.54,0.20,0.05,0.06,0.05,0.06,0.27,0.42,0.36,0.42
     *  ,0.61,0.59,0.50,0.08,0.06,0.02,0.03,0.02,0.16,0.40,0.17,0.31
     *  ,0.68,0.30,0.28,0.13,0.10,0.16,0.14,0.08,0.19,0.50,0.63,0.62
     *  ,0.63,0.45,0.51,0.13,0.06,0.07,0.04,0.06,0.27,0.42,0.28,0.35
     *  ,0.68,0.53,0.57,0.15,0.05,0.00,0.00,0.05,0.31,0.33,0.18,0.22
     *  ,0.59,0.32,0.21,0.06,0.10,0.16,0.12,0.10,0.19,0.41,0.55,0.54
     *  ,0.69,0.43,0.43,0.15,0.06,0.05,0.05,0.08,0.29,0.39,0.23,0.29
     *  ,0.57,0.51,0.56,0.13,0.06,0.00,0.00,0.05,0.34,0.27,0.19,0.24
     *  ,0.49,0.16,0.13,0.09,0.04,0.11,0.11,0.05,0.17,0.32,0.49,0.49
     *  ,0.60,0.42,0.38,0.11,0.06,0.04,0.07,0.07,0.25,0.36,0.21,0.25
     *  ,0.65,0.48,0.53,0.17,0.05,0.00,0.00,0.11,0.29,0.14,0.20,0.22
     *  ,0.44,0.16,0.18,0.07,0.04,0.04,0.07,0.03,0.12,0.23,0.39,0.43
     *  ,0.57,0.40,0.35,0.14,0.06,0.03,0.04,0.07,0.18,0.27,0.14,0.15
     *  ,0.45,0.50,0.50,0.19,0.06,0.00,0.02,0.05,0.26,0.19,0.15,0.18
     *  ,0.23,0.09,0.12,0.06,0.04,0.02,0.02,0.02,0.10,0.03,0.14,0.26
     *  ,0.39,0.34,0.22,0.07,0.03,0.00,0.04,0.01,0.15,0.01,0.04,0.14
     *  ,0.41,0.39,0.35,0.13,0.02,0.00,0.00,0.06,0.17,0.07,0.06,0.14
     *  ,0.07,0.02,0.03,0.00,0.00,0.00,0.00,0.00,0.00,0.01,0.03,0.08
     *  ,0.19,0.14,0.14,0.00,0.03,0.01,0.02,0.00,0.09,0.00,0.01,0.00
     *  ,0.18,0.09,0.16,0.08,0.01,0.00,0.02,0.02,0.15,0.00,0.03,0.04/
*
        data coef_sfb/
     *   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.03,0.00,0.00,0.00,0.00
     *  ,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.02,0.01,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.01,0.00,0.00,0.00,0.00,0.00,0.01,0.01,0.00,0.00,0.00
     *  ,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.05,0.03,0.00,0.02,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.04,0.00,0.01,0.00,0.00,0.00,0.01,0.01,0.05,0.00,0.00
     *  ,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.04,0.00,0.03,0.03,0.00
     *  ,0.01,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.01,0.00
     *  ,0.01,0.04,0.04,0.03,0.00,0.01,0.00,0.01,0.00,0.27,0.14,0.06
     *  ,0.05,0.04,0.02,0.00,0.00,0.00,0.00,0.04,0.09,0.48,0.43,0.27
     *  ,0.05,0.04,0.01,0.00,0.00,0.00,0.00,0.00,0.00,0.13,0.16,0.06
     *  ,0.26,0.12,0.29,0.04,0.01,0.02,0.00,0.01,0.08,0.65,0.56,0.45
     *  ,0.43,0.42,0.42,0.09,0.00,0.02,0.00,0.00,0.34,0.67,0.73,0.72
     *  ,0.10,0.05,0.04,0.00,0.01,0.00,0.00,0.00,0.00,0.18,0.39,0.15
     *  ,0.61,0.37,0.51,0.06,0.01,0.02,0.01,0.01,0.18,0.72,0.63,0.80
     *  ,0.77,0.66,0.70,0.19,0.00,0.02,0.02,0.02,0.41,0.68,0.88,0.85
     *  ,0.24,0.11,0.08,0.00,0.01,0.00,0.00,0.00,0.00,0.28,0.51,0.29
     *  ,0.75,0.48,0.57,0.11,0.00,0.02,0.01,0.01,0.19,0.77,0.77,0.88
     *  ,0.89,0.81,0.74,0.21,0.02,0.02,0.02,0.02,0.42,0.71,0.93,0.95
     *  ,0.49,0.30,0.19,0.00,0.00,0.00,0.00,0.01,0.06,0.38,0.64,0.48
     *  ,0.86,0.60,0.62,0.12,0.00,0.02,0.01,0.00,0.18,0.81,0.84,0.94
     *  ,0.88,0.79,0.70,0.26,0.03,0.02,0.02,0.02,0.36,0.61,0.98,0.93
     *  ,0.60,0.46,0.31,0.03,0.00,0.01,0.00,0.00,0.09,0.50,0.71,0.58
     *  ,0.90,0.65,0.66,0.10,0.00,0.02,0.01,0.02,0.15,0.69,0.80,0.86
     *  ,0.84,0.75,0.64,0.09,0.03,0.00,0.00,0.04,0.26,0.54,0.78,0.92
     *  ,0.62,0.59,0.44,0.01,0.00,0.01,0.00,0.00,0.13,0.52,0.77,0.63
     *  ,0.84,0.67,0.63,0.11,0.00,0.00,0.03,0.03,0.18,0.65,0.75,0.84
     *  ,0.81,0.63,0.47,0.06,0.02,0.00,0.00,0.05,0.14,0.49,0.76,0.91
     *  ,0.58,0.63,0.47,0.09,0.00,0.07,0.01,0.04,0.15,0.48,0.68,0.61                     
     *  ,0.79,0.63,0.55,0.12,0.01,0.01,0.02,0.05,0.13,0.57,0.51,0.63
     *  ,0.72,0.54,0.43,0.11,0.02,0.00,0.00,0.09,0.16,0.39,0.59,0.72
     *  ,0.46,0.55,0.39,0.07,0.01,0.03,0.03,0.06,0.15,0.37,0.51,0.50
     *  ,0.61,0.43,0.38,0.11,0.01,0.03,0.02,0.03,0.10,0.38,0.38,0.60
     *  ,0.58,0.42,0.38,0.15,0.02,0.00,0.00,0.11,0.13,0.24,0.41,0.51
     *  ,0.36,0.36,0.21,0.04,0.04,0.03,0.06,0.05,0.06,0.26,0.39,0.43
     *  ,0.43,0.31,0.24,0.09,0.02,0.00,0.02,0.02,0.06,0.24,0.24,0.40
     *  ,0.53,0.19,0.28,0.13,0.02,0.02,0.02,0.09,0.13,0.17,0.24,0.40
     *  ,0.32,0.27,0.17,0.03,0.04,0.02,0.04,0.03,0.06,0.13,0.34,0.36
     *  ,0.42,0.31,0.20,0.09,0.03,0.00,0.02,0.01,0.07,0.19,0.24,0.32
     *  ,0.44,0.10,0.23,0.13,0.03,0.02,0.00,0.09,0.12,0.17,0.21,0.33
     *  ,0.32,0.23,0.16,0.00,0.02,0.04,0.03,0.03,0.06,0.15,0.29,0.34
     *  ,0.36,0.26,0.28,0.07,0.01,0.00,0.01,0.02,0.04,0.19,0.17,0.27
     *  ,0.34,0.14,0.26,0.09,0.03,0.02,0.00,0.06,0.13,0.09,0.16,0.22
     *  ,0.29,0.21,0.15,0.00,0.02,0.02,0.02,0.03,0.11,0.16,0.26,0.28
     *  ,0.29,0.22,0.27,0.05,0.01,0.00,0.01,0.01,0.02,0.14,0.09,0.19
     *  ,0.25,0.19,0.25,0.07,0.02,0.02,0.00,0.00,0.09,0.07,0.12,0.15
     *  ,0.23,0.20,0.16,0.00,0.03,0.04,0.00,0.00,0.08,0.09,0.21,0.18
     *  ,0.22,0.21,0.19,0.02,0.02,0.00,0.01,0.03,0.04,0.08,0.06,0.14
     *  ,0.20,0.12,0.23,0.02,0.00,0.02,0.00,0.00,0.05,0.05,0.09,0.11
     *  ,0.14,0.16,0.13,0.00,0.03,0.04,0.00,0.00,0.05,0.05,0.04,0.09
     *  ,0.09,0.13,0.16,0.03,0.01,0.00,0.01,0.03,0.01,0.03,0.04,0.10
     *  ,0.14,0.09,0.17,0.02,0.02,0.00,0.00,0.02,0.04,0.04,0.03,0.07
     *  ,0.00,0.11,0.09,0.00,0.02,0.00,0.00,0.00,0.01,0.00,0.02,0.02
     *  ,0.02,0.06,0.11,0.00,0.00,0.00,0.00,0.01,0.00,0.00,0.01,0.02
     *  ,0.06,0.09,0.13,0.00,0.02,0.00,0.03,0.02,0.03,0.01,0.02,0.01/
*
        param(1)=idoy
        param(2)=f107
        param(3)=geolat
        n=idiy-365
*
        if(param(1).le.31.)kf=1
         if(param(1).gt.31..and.param(1).le.(59+n))kf=2
	      if(param(1).gt.(59+n).and.param(1).le.(90+n))kf=3
           if(param(1).gt.(90+n).and.param(1).le.(120+n))kf=4
            if(param(1).gt.(120+n).and.param(1).le.(151+n))kf=5
	         if(param(1).gt.(151+n).and.param(1).le.(181+n))kf=6
             if(param(1).gt.(181+n).and.param(1).le.(212+n))kf=7
            if(param(1).gt.(212+n).and.param(1).le.(243+n))kf=8
           if(param(1).gt.(243+n).and.param(1).le.(273+n))kf=9
	      if(param(1).gt.(273+n).and.param(1).le.(304+n))kf=10
         if(param(1).gt.(304+n).and.param(1).le.(334+n))kf=11
        if(param(1).gt.(334+n).and.param(1).le.(365+n))kf=12
*
      do i=1,32
       do j=1,3
        do k=1,12
           sosf(1,i,j,k)=0.
           sosf(2,i,j,k)=0.           
        enddo
       enddo
      enddo
*         
      kc=0
      do i=5,23
       do j=1,3
        do k=1,12
           kc=kc+1
           sosf(1,i,j,k)=coef_sfa(kc)
           sosf(2,i,j,k)=coef_sfb(kc) 
        enddo
       enddo
      enddo
           
      kk=0    
      do it=1600,3200,50      
        slt=it/100.
        osft=0.
        do i=1,23
          il=i+3
	      if(il.gt.23)il=il-23
          do j=1,12
	        jl=j+2
	        if(jl.gt.12)jl=jl-12
            do m=1,3
	          ml=m+1
	          if(ml.gt.3)ml=ml-3
              do  l=1,2
                bspl4=bspl4t(i,slt)*bspl2s(j,param(1))*
     &	         bspl2l(l,param(3))*bspl2f(m,param(2))
                osft=osft+bspl4*sosf(l,il,ml,jl)           
              enddo
            enddo
          enddo
        enddo
        if(slt.gt.17.98.and.slt.lt.30.01)then
          kk=kk+1
          osfbr(kk)=osft 
          endif
      enddo
*
*
      do iii=1,25 
         if(osfbr(iii).gt.1.) osfbr(iii)=1.
         if(osfbr(iii).lt.0.) osfbr(iii)=0.
         enddo
      return
      end
*
**********************************************************************
      function bspl4t(i,t1)
**********************************************************************
      dimension tt(0:78),b(30,30)
*
      data tt/16.00,16.50,17.00,17.50,18.00,18.50,19.00,19.50,20.00,
     &  20.50,21.00,22.00,23.00,24.00,25.00,26.00,27.00,27.50,28.00,
     &  28.50,29.00,29.50,30.00,30.50,31.00,32.00,40.00,40.50,41.00,
     &  41.50,42.00,42.50,43.00,43.50,44.00,44.50,45.00,46.00,47.00,
     &  48.00,49.00,50.00,51.00,51.50,52.00,52.50,53.00,53.50,54.00,
     &  54.50,55.00,56.00,64.00,64.50,65.00,65.50,66.00,66.50,67.00,
     &  67.50,68.00,68.50,69.00,70.00,71.00,72.00,73.00,74.00,75.00,
     &  75.50,76.00,76.50,77.00,77.50,78.00,78.50,79.00,80.00,88.00/
*
      t=t1
      if(i.ge.0.and.t.lt.tt(i)) then
         t=t+24.
      endif
      do j=i,i+4-1
        if(t.ge.tt(j).and.t.lt.tt(j+1)) then
           b(j,1)=1.
        else
           b(j,1)=0.
        endif
      enddo
      do j=2,4
        do k=i,i+4-j
          b(k,j)=(t-tt(k))/(tt(k+j-1)-tt(k))*b(k,j-1)
          b(k,j)=b(k,j)+(tt(k+j)-t)/(tt(k+j)-tt(k+1))*b(k+1,j-1)
        enddo
      enddo
*
      bspl4t=b(i,4)
*
      return
*
      end
*
******************************************************************
      function bspl2s(i,t1)
******************************************************************
      dimension ts(0:36),b(30,30)
*
      data ts/ 15,46,74,105,135,166,196,227,258,288,319,349,
     *        380,411,439,470,500,531,561,592,623,653,684,714,
     *        745,776,804,835,865,896,926,957,988,1018,1049,
     *        1079,1110/
*
      t=t1
      if(i.ge.0.and.t.lt.ts(i)) then
         t=t+365.
      endif
      do j=i,i+2-1
        if(t.ge.ts(j).and.t.lt.ts(j+1)) then
           b(j,1)=1.
        else
           b(j,1)=0.
        endif
      enddo
*
      do j=2,2
        do k=i,i+4-j
          b(k,j)=(t-ts(k))/(ts(k+j-1)-ts(k))*b(k,j-1)
          b(k,j)=b(k,j)+(ts(k+j)-t)/(ts(k+j)-ts(k+1))*b(k+1,j-1)
       enddo
      enddo
*
      bspl2s=b(i,2)
      return
      end
*
*******************************************************************
      function bspl2l(i,t1)
*******************************************************************
      dimension ts(0:6),b(30,30)
*
      data ts/ 94.,112.5,454.,472.5,814.,832.5,1174./
*
      t=t1
      if(i.ge.0.and.t.lt.ts(i)) then
         t=t+360.
      endif
      do j=i,i+2-1
        if(t.ge.ts(j).and.t.lt.ts(j+1)) then
           b(j,1)=1.
        else
           b(j,1)=0.
        endif
      enddo
*
      do j=2,2
        do k=i,i+2-j
          b(k,j)=(t-ts(k))/(ts(k+j-1)-ts(k))*b(k,j-1)
          b(k,j)=b(k,j)+(ts(k+j)-t)/(ts(k+j)-ts(k+1))*b(k+1,j-1)
        enddo
      enddo
*
      bspl2l=b(i,2)
*
      return
*
      end
*
*************************************************************************
      function bspl2f(i,t1)
*************************************************************************
       dimension ts(0:9),b(30,30),
     & ifnodes1(12),ifnodes2(12),ifnodes3(12)
       common/mflux/kf,n
*
      data ifnodes1 / 78, 77, 75, 79, 80, 77, 78, 80, 76, 81, 78, 78/
      data ifnodes2 /144,140,139,142,139,146,142,139,150,151,150,157/
      data ifnodes3 /214,211,201,208,213,220,203,209,213,215,236,221/ 
*
	ts(0)=ifnodes1(kf)
        ts(1)=ifnodes2(kf)
	ts(2)=ifnodes3(kf)
	ts(3)=ts(1)+367
        ts(4)=ts(2)+367
	ts(5)=ts(3)+367
	ts(6)=ts(4)+367
        ts(7)=ts(5)+367
	ts(8)=ts(6)+367
        ts(9)=ts(7)+367
*
      t=t1
      if(i.ge.0.and.t.lt.ts(i)) then
         t=t+367.
      endif
      do j=i,i+2-1
        if(t.ge.ts(j).and.t.lt.ts(j+1)) then
           b(j,1)=1.
        else
           b(j,1)=0.
        endif
      enddo
*
      do j=2,2
        do k=i,i+2-j
          b(k,j)=(t-ts(k))/(ts(k+j-1)-ts(k))*b(k,j-1)
          b(k,j)=b(k,j)+(ts(k+j)-t)/(ts(k+j)-ts(k+1))*b(k+1,j-1)
        enddo
      enddo
*
      bspl2f=b(i,2)
      return
      end
C
C
        function ckp(ap)
C-----------------------------------------------------------------------
C Converts ap index (ap is integer variable varying from 0 to 400) into 
C kp index (xkp is real variable varying from 0 to 9). Using standard
C tables for deriving the 3-hourly ap index from the 3-hourly Kp index
C (e.g., http://www.ngdc.noaa.gov/stp/GEOMAG/kp_ap.shtml) 
C-----------------------------------------------------------------------

        integer		ap,ap_array
        real		kp_array,ap_log_array
        dimension 	ap_array(28),kp_array(28),alap(28)
        data ap_array /0,2,3,4,5,6,7,9,12,15,18,22,27,32,39,48,56,67,
     &                 80,94,111,132,154,179,207,236,300,400/
        
        do 1256 i=2,28
1256       kp_array(i)=(i-1)/3.
		
        if(ap.eq.0) then
        	ckp=0.0
        	return
        	endif
        if(ap.eq.1) then
        	ckp=kp_array(2)/2.
        	return
        	endif
        if(ap.lt.8.and.ap.gt.1) then
        	ckp=kp_array(ap)
        	return
        	endif

        xl_ap=log(ap*1.0)
                	
        i=8
1257    alap(i)=log(ap_array(i)*1.0)
        if(xl_ap.gt.alap(i)) then
                i=i+1
                if(i.le.28) goto 1257
                endif

        slope=(kp_array(i)-kp_array(i-1))/(alap(i)-alap(i-1))
       
		ckp = kp_array(i) + slope * (xl_ap - alap(i))
		
		return
		end
C                   
C        
		subroutine auroral_boundary(xkp,xmlt,cgmlat,ab_mlat)
C-----------------------------------------------------------------------
C Computes equatorward auroral boundary values for givern kp value.
C kp given in units of 0.1 (xkp) for the range from 0.0 to 9.0. Model 
C values are only used for kp=0,1,2,3,4,5,6,7,8,9 and a linear inter-
C polation is applied for intermediate kp values.
C 
C The auroral oval boundary is given as an array for corrected magnetic 
C latitude CGM (ab_mlat). The 48 values correspond to the MLT values 
C of 0.0,0.5,1.0,1.5,2.0 .. 23.5. If the input xmlt is greater than
C -1, then the program determines the CGM latitude, cgmlat, that 
C corresponds to the given MLT value (xmlt).
C
C Y. Zhang and L.J. Paxton, An empirical Kp-dependent global auroral 
C model based on TIMED/GUVI FUV data, Journal of Atmospheric and 
C Solar-Terrestrial Physics 70, 1231–1242, 2008.
C 
C----------------------------------------------------------------------- 

        dimension zp_mlat(48,10),ab_mlat(48),ab_mlt(48)

      data zp_mlat/
     * 66.1,65.9,65.9,66.0,66.2,66.5,66.7,67.0,67.4,67.8,68.2,68.7,
     * 69.4,70.0,70.5,70.8,71.0,71.3,71.9,72.7,73.8,75.4,77.0,77.8,
     * 77.3,76.7,76.4,76.2,75.9,75.4,74.7,74.1,73.5,73.0,72.5,71.9,
     * 71.6,71.1,70.6,70.0,69.2,68.5,67.9,67.5,67.2,66.9,66.7,66.4,
     * 63.0,62.9,63.0,63.0,63.1,63.2,63.3,63.6,64.0,64.5,65.0,65.6,
     * 66.2,66.7,67.1,67.6,68.1,68.6,69.4,70.3,71.5,72.8,74.1,74.9,
     * 74.8,74.7,74.7,74.5,74.0,73.1,72.2,71.2,70.4,69.7,68.9,68.2,
     * 67.5,66.9,66.3,65.8,65.4,65.0,64.5,64.1,63.7,63.3,63.1,62.9,
     * 61.1,61.3,61.5,61.7,61.9,62.1,62.2,62.4,62.7,63.0,63.4,64.0,
     * 64.4,65.0,65.5,65.9,66.4,66.9,67.5,68.3,69.3,70.5,71.6,72.3,
     * 72.7,72.8,72.8,72.4,71.6,70.6,69.7,68.9,68.2,67.5,66.7,65.9,
     * 65.0,64.3,63.7,63.4,63.1,62.8,62.4,62.0,61.5,61.2,61.0,61.0,
     * 59.6,60.0,60.4,60.7,60.7,60.7,60.5,60.4,60.6,61.1,61.8,62.5,
     * 63.0,63.4,63.7,64.1,64.6,65.4,66.2,67.0,67.7,68.5,69.3,70.1,
     * 70.6,70.9,70.9,70.4,69.3,68.0,66.9,66.0,65.2,64.5,63.7,63.0,
     * 62.3,61.7,61.2,60.9,60.6,60.4,60.2,60.1,59.8,59.6,59.4,59.4,
     * 58.5,58.8,59.2,59.4,59.4,59.2,58.9,58.9,59.2,59.7,60.5,61.2,
     * 61.7,62.0,62.3,62.6,63.3,64.1,65.1,65.9,66.4,66.9,67.5,68.4,
     * 69.0,69.2,68.9,68.1,66.7,65.3,64.2,63.4,62.7,62.0,61.1,60.4,
     * 59.7,59.2,58.9,58.6,58.4,58.4,58.4,58.5,58.5,58.4,58.3,58.3,
     * 57.6,57.8,57.9,57.9,57.7,57.5,57.4,57.5,57.9,58.6,59.3,59.8,
     * 60.3,60.5,60.8,61.2,62.0,63.0,64.1,64.9,65.4,65.7,66.2,66.8,
     * 67.2,66.8,66.0,64.8,63.4,62.1,61.3,60.7,60.1,59.3,58.2,57.1,
     * 56.6,56.3,56.1,56.0,56.0,56.2,56.6,56.9,57.1,57.3,57.4,57.5,
     * 54.3,54.9,55.4,55.6,55.6,55.3,55.1,55.0,55.3,55.8,56.5,57.2,
     * 57.8,58.3,58.7,59.4,60.3,61.2,62.0,62.8,63.4,63.9,64.1,64.1,
     * 63.8,63.3,62.5,61.5,60.2,58.9,57.7,56.7,56.0,55.5,55.1,54.8,
     * 54.6,54.3,53.9,53.4,53.2,53.1,53.3,53.4,53.5,53.5,53.6,53.8,
     * 52.9,53.6,54.2,54.6,54.6,54.3,54.0,53.7,53.8,54.1,54.8,55.7,
     * 56.4,56.9,57.4,58.0,58.8,59.6,60.2,60.8,61.7,62.4,62.6,62.2,
     * 61.5,60.7,59.8,58.9,57.9,56.8,55.5,54.5,53.8,53.4,53.3,53.3,
     * 53.5,53.2,52.7,52.1,51.7,51.7,51.7,51.9,51.9,52.0,52.1,52.4,
     * 51.8,52.5,53.2,53.6,53.6,53.3,52.9,52.5,52.4,52.6,53.3,54.2,
     * 55.0,55.6,56.1,56.7,57.3,57.9,58.1,58.6,59.7,60.7,60.9,60.3,
     * 59.2,58.1,57.1,56.3,55.5,54.6,53.5,52.5,51.8,51.4,51.4,51.7,
     * 52.0,51.9,51.4,50.8,50.4,50.3,50.4,50.5,50.6,50.7,50.8,51.2,
     * 50.9,51.7,52.4,52.9,52.9,52.5,52.0,51.5,51.3,51.4,52.1,53.0,
     * 53.9,54.5,55.0,55.5,56.0,56.4,56.4,56.8,58.0,59.3,59.5,58.7,
     * 57.4,56.1,54.9,54.1,53.5,52.8,51.8,50.8,50.1,49.7,49.8,50.4,
     * 50.9,50.9,50.3,49.7,49.3,49.2,49.3,49.4,49.5,49.6,49.8,50.2/

        
        if(xkp.gt.9.0) xkp=9.0
        kp1=int(xkp)+1
        xkp1=int(xkp)*1.0
        kp2=kp1+1
        if(kp2.gt.10) kp2=10

        do i=1,48 
           ab_mlat(i)=zp_mlat(i,kp1)+(xkp-xkp1)*
     &      	(zp_mlat(i,kp2)-zp_mlat(i,kp1))
           enddo
           
        cgmlat=-99.99

        if(xmlt.lt.0.0) return
        
        do i=1,48 
        	ab_mlt(i)=(i-1)*.5
			enddo
        i1=int(xmlt/0.5)+1
        if(i1.ge.48) i1=1
        i2=i1+1
      
        s1=(zp_mlat(i2,kp1)-zp_mlat(i1,kp1))/(ab_mlt(i2)-ab_mlt(i1))
        zmlkp1=zp_mlat(i1,kp1)+(xmlt-ab_mlt(i1))*s1
        s2=(zp_mlat(i2,kp2)-zp_mlat(i1,kp2))/(ab_mlt(i2)-ab_mlt(i1))
        zmlkp2=zp_mlat(i1,kp2)+(xmlt-ab_mlt(i1))*s2
        
        cgmlat=zmlkp1+(xkp-xkp1)*(zmlkp2-zmlkp1)
		return
		end
C
C
