      SUBROUTINE TABLEZ                                                 TABZ001 

C     CALCULATES COLLISION FREQUENCY AND ITS GRADIENT FROM PROFILES     TABZ002 

C     HAVING THE SAME FORM AS THOSE USED BY CROFTS RAY TRACING PROGRAM  TABZ003 

C MAKES AN EXPONENTIAL EXTRAPOLATION DOWN USING THE BOTTOM TWO POINTS   TABZ004 

C        NEEDS SUBROUTINE GAUSEL                                        TABZ005 

      DIMENSION HPC(100),FN2C(100),ALPHA(100),BETA(100),                TABZ006 

     1 GAMMA(100),DELTA(100),MAT(4,5),SLOPE(100)                        TABZ007 

      COMMON /CONST/ PI,PIT2,PID2,DUM(5)                                TABZ008 

      COMMON /ZZ/ MODZ,Z,PZPR,PZPTH,PZPPH                               TABZ009 

      COMMON R(6) /WW/ ID(10),W0,W(400)                                 TABZ010 

      EQUIVALENCE (EARTHR,W(2)),(F,W(6)),(READNU,W(250))                TABZ011 

      REAL MAT                                                          TABZ012 

      DATA (MODZ=6HTABLEZ)                                              TABZ013 

      ENTRY COLFRZ                                                      TABZ014 

      IF (READNU.EQ.0.) GO TO 10                                        TABZ015 

      READNU=0.                                                         TABZ016 

      READ 2, NOC,(HPC(I),FN2C(I),I=1,NOC)                              TABZ017 

  2   FORMAT(I4/(F8.2,E12.4))                                           TABZ018 

      PRINT 1200, (HPC(I),FN2C(I), I=1,NOC)                             TABZ019 

 1200 FORMAT(1H1,14X,6HHEIGHT,4X,20HCOLLISION FREQUENCY   /             TABZ020 

     1(1X,F20.10,E20.10))                                               TABZ021 

      A=0.                                                              TABZ022 

      IF(FN2C(1).NE.0.) A=ALOG(FN2C(2)/FN2C(1))/(HPC(2)-HPC(1))         TABZ023 

      FN2C(1)=FN2C(1)/PIT2*1.E-6                                        TABZ024 

      FN2C(2)=FN2C(2)/PIT2*1.E-6                                        TABZ025 

      SLOPE(1)=A*FN2C(1)                                                TABZ026 

      SLOPE(NOC)=0.                                                     TABZ027 

      DO 5 I=2,NOC                                                      TABZ028 

      IF(I.EQ.NOC) GO TO 6                                              TABZ029 

      FN2C(I+1)= FN2C(I+1)/PIT2*1.E-6                                   TABZ030 

      DO 3 J=1,3                                                        TABZ031 

      M=I+J-2                                                           TABZ032 

      MAT(J,1)=1.                                                       TABZ033 

      MAT(J,2)=HPC(M)                                                   TABZ034 

      MAT(J,3)=HPC(M)**2                                                TABZ035 

  3   MAT(J,4)=FN2C(M)                                                  TABZ036 

      CALL GAUSEL (MAT,4,3,4,NRANK)                                     TABZ037 

      IF (NRANK.LT.3) GO TO 20                                          TABZ038 

      SLOPE(I)=MAT(2,4)+2.*MAT(3,4)*HPC(I)                              TABZ039 

  6   CONTINUE                                                          TABZ040 

      DO 4 J=1,2                                                        TABZ041 

      M=I+J-2                                                           TABZ042 

      MAT(J,1)=1.                                                       TABZ043 

      MAT(J,2)=HPC(M)                                                   TABZ044 

      MAT(J,3)=HPC(M)**2                                                TABZ045 

      MAT(J,4)=HPC(M)**3                                                TABZ046 

      MAT(J,5)=FN2C(M)                                                  TABZ047 

      L=J+2                                                             TABZ048 

      MAT(L,1)=0.                                                       TABZ049 

      MAT(L,2)=1.                                                       TABZ050 

      MAT(L,3)=2.*HPC(M)                                                TABZ051 

      MAT(L,4)=3.*HPC(M)**2                                             TABZ052 

  4   MAT(L,5)=SLOPE(M)                                                 TABZ053 

      CALL GAUSEL (MAT,4,4,5,NRANK)                                     TABZ054 

      IF (NRANK.LT.4) GO TO 20                                          TABZ055 

      ALPHA(I)=MAT(1,5)                                                 TABZ056 

      BETA(I)=MAT(2,5)                                                  TABZ057 

      GAMMA(I)=MAT(3,5)                                                 TABZ058 

  5   DELTA(I)=MAT(4,5)                                                 TABZ059 

      JUP=2                                                             TABZ060 

   10 H=R(1)-EARTHR                                                     TABZ061 

      IF (H.GE.HPC(1)) GO TO 12                                         TABZ062 

   11 JUP=2                                                             TABZ063 

      Z=FN2C(1)*EXP(A*(H-HPC(1)))/F                                     TABZ064 

      PZPR=A*Z                                                          TABZ065 

      RETURN                                                            TABZ066 

   12 IF (H.GE.HPC(NOC)) GO TO 18                                       TABZ067 

      NSTEP=1                                                           TABZ068 

      IF (H.LT.HPC(JUP-1)) NSTEP=-1                                     TABZ069 

   15 IF (HPC(JUP-1).GT.H.OR.H.GE.HPC(JUP)) GO TO 16                    TABZ070 

      Z=(ALPHA(JUP)+H*(BETA(JUP)+H*(GAMMA(JUP)+H*DELTA(JUP))))/F        TABZ071 

      PZPR=(BETA(JUP)+H*(2.*GAMMA(JUP)+H*3.*DELTA(JUP)))/F              TABZ072 

      RETURN                                                            TABZ073 

   16 JUP=JUP+NSTEP                                                     TABZ074 

      IF (JUP.LT.2) GO TO 11                                            TABZ075 

      IF (JUP.LT.NOC) GO TO 15                                          TABZ076 

   18 JUP=NOC                                                           TABZ077 

      Z=FN2C(NOC)/F                                                     TABZ078 

      PZPR=0.                                                           TABZ079 

      RETURN                                                            TABZ080 

   20 PRINT 21, I,HPC(I)                                                TABZ081 

  21  FORMAT(4H THE,I4,58HTH POINT IN THE COLLISION FREQUENCY PROFILE HATABZ082 

     1S THE HEIGHT,F8.2,40H KM, WHICH IS THE SAME AS ANOTHER POINT.)    TABZ083 

      CALL EXIT                                                         TABZ084 

         END                                                            TABZ085 

      SUBROUTINE CONSTZ                                                 CONZ001 

C     CONSTANT COLLISION FREQUENCY                                      CONZ002 

      COMMON /CONST/ PI,PIT2,PID2,DUM(5)                                CONZ003 

      COMMON /ZZ/ MODZ,Z,PZPR,PZPTH,PZPPH                               CONZ004 

      COMMON R(6) /WW/ ID(10),W0,W(400)                                 CONZ005 

      EQUIVALENCE (EARTHR,W(2)),(F,W(6)),(NU,W(251)),(HMIN,W(252))      CONZ006 

      REAL NU                                                           CONZ007 

      DATA (MODZ=6HCONSTZ)                                              CONZ008 

      ENTRY COLFRZ                                                      CONZ009 

      H=R(1)-EARTHR                                                     CONZ010 

      Z=0.                                                              CONZ011 

      IF (H.GT.HMIN) Z=NU/(PIT2*F)*1.E-6                                CONZ012 

      RETURN                                                            CONZ013 

         END                                                            CONZ014-

      SUBROUTINE EXPZ                                                   EXPZ001 

C        EXPONENTIAL COLLISION FREQUENCY MODEL                          EXPZ002 

      COMMON /CONST/ PI,PIT2,PID2,DUM(5)                                EXPZ003 

      COMMON /ZZ/ MODZ,Z,PZPR,PZPTH,PZPPH                               EXPZ004 

      COMMON R(6) /WW/ ID(10),W0,W(400)                                 EXPZ005 

      REAL NU,NU0                                                       EXPZ006 

      EQUIVALENCE (EARTHR,W(2)),(F,W(6)),(NU0,W(251)),(H0,W(252)),      EXPZ007 

     1 (A,W(253))                                                       EXPZ008 

      DATA (MODZ=6H EXPZ )                                              EXPZ009 

      ENTRY COLFRZ                                                      EXPZ010 

      H=R(1)-EARTHR                                                     EXPZ011 

      NU=NU0/EXP (A*(H-H0))                                             EXPZ012 

      Z=NU/(PIT2*F*1.E6)                                                EXPZ013 

      PZPR   =-A*Z                                                      EXPZ014 

      RETURN                                                            EXPZ015 

         END                                                            EXPZ016-

      SUBROUTINE EXPZ2                                                  XPZ2001 

C          COLLISION FREQUENCY PROFILE FROM TWO EXPONENTIALS            XPZ2002 

      COMMON /CONST/ PI,PIT2,PID2,DUM(5)                                XPZ2003 

      COMMON /ZZ/ MODZ,Z,PZPR,PZPTH,PZPPH                               XPZ2004 

      COMMON R(6) /WW/ ID(10),W0,W(400)                                 XPZ2005 

      EQUIVALENCE (EARTHR,W(2)),(F,W(6)),(NU1,W(251)),(H1,W(252)),      XPZ2006 

     1 (A1,W(253)),(NU2,W(254)),(H2,W(255)),(A2,W(256))                 XPZ2007 

      REAL NU1,NU2                                                      XPZ2008 

      DATA (MODZ=6H EXPZ2)                                              XPZ2009 

      ENTRY COLFRZ                                                      XPZ2010 

      H=R(1)-EARTHR                                                     XPZ2011 

      EXP1= NU1* EXP(-A1*(H-H1))                                        XPZ2012 

      EXP2= NU2* EXP(-A2*(H-H2))                                        XPZ2013 

      Z=(EXP1+EXP2)/(PIT2*F*1.E6)                                       XPZ2014 

      PZPR=(-A1*EXP1-A2*EXP2)/(PIT2*F*1.E6)                             XPZ2015 

      RETURN                                                            XPZ2016 

         END                                                            XPZ2017-

