*DK ADDIAG                                                                ADDIAG.1
      SUBROUTINE ADDIAG                                                   ADDIAG.2
C     ****                                                                ADDIAG.3
C     ****     CALCULATES Z,M AND COS(PHI)*V ON LINE JP2                  ADDIAG.4
C     ****                                                                ADDIAG.5
      INCLUDE 'param.h'                                                   ADDIAG.6
      INCLUDE 'vscrw.h'                                                   ADDIAG.7
      INCLUDE 'buffe.h'                                                   ADDIAG.8
      INCLUDE 'const.h'                                                   ADDIAG.9
      INCLUDE 'index.h'                                                   ADDIAG.10
      INCLUDE 'start.h'                                                   ADDIAG.11
      INCLUDE 'phycs.h'                                                   ADDIAG.12
      INCLUDE 'epara.h'                                                   ADDIAG.13
      INCLUDE 'edphi.h'                                                   ADDIAG.14
      COMPLEX*16 EXPT                                                     ADDIAG.15
C     ****                                                                ADDIAG.16
C     ****     NVC=COS(PHI)*V                                             ADDIAG.17
C     ****                                                                ADDIAG.18
      NVCK=NJP2+NVC                                                       ADDIAG.19
      NVK=NJP2+NV                                                         ADDIAG.20
      DO I=1,LEN2                                                         ADDIAG.21
       F(I,NVCK)=CS(J+2)*F(I,NVK)                                         ADDIAG.22
      ENDDO                                                               ADDIAG.23
C     ****                                                                ADDIAG.24
C     ****     CALCULATE MBAR                                             ADDIAG.25
C     ****                                                                ADDIAG.26
      NPS1K=NJP2+NPS                                                      ADDIAG.27
      NPS2K=NJP2+NPS2                                                     ADDIAG.28
      NMSK=NJP2+NMS                                                       ADDIAG.29
      DO I=1,LEN3                                                         ADDIAG.30
       F(I,NMSK)=1/(F(I,NPS1K)/RMASS(1)+F(I,NPS2K)/RMASS(2)+              ADDIAG.31
     A           (1-F(I,NPS1K)-F(I,NPS2K))/RMASS(3))                      ADDIAG.32
      ENDDO                                                               ADDIAG.33
C     ****                                                                ADDIAG.34
C     ****     T1 = MBAR(K=0)  (LINEAR EXTRAPOLATION)                     ADDIAG.35
C     ****                                                                ADDIAG.36
      NMSK=NJP2+NMS                                                       ADDIAG.37
      DO I=1,LEN1                                                         ADDIAG.38
       T1(I)=1.5*F(I,NMSK)-0.5*F(I,NMSK+1)                                ADDIAG.39
      ENDDO                                                               ADDIAG.40
C     ****                                                                ADDIAG.41
C     ****     MBAR(K) = 0.5*(MBAR(K+1/2)+MBAR(K-1/2)),                   ADDIAG.42
C     ****       K = KMAXP1,2,1                                           ADDIAG.43
C     ****                                                                ADDIAG.44
      NMSK=NJP2+NMS+KMAXP1                                                ADDIAG.45
      DO K=1,KMAX                                                         ADDIAG.46
       NMSK=NMSK-1                                                        ADDIAG.47
       DO I=1,LEN1                                                        ADDIAG.48
        F(I,NMSK)=0.5*(F(I,NMSK)+F(I,NMSK-1))                             ADDIAG.49
       ENDDO                                                              ADDIAG.50
      ENDDO                                                               ADDIAG.51
C     ****                                                                ADDIAG.52
C     ****     MBAR(1) = T1                                               ADDIAG.53
C     ****                                                                ADDIAG.54
      NMSK=NJP2+NMS                                                       ADDIAG.55
      DO I=1,LEN1                                                         ADDIAG.56
       F(I,NMSK)=T1(I)                                                    ADDIAG.57
      ENDDO                                                               ADDIAG.58
C     ****                                                                ADDIAG.59
C     ****     CALCULATE Z                                                ADDIAG.60
C     ****                                                                ADDIAG.61
      NTK=NJP2+NT                                                         ADDIAG.62
      NMSK=NJP2+NMS                                                       ADDIAG.63
C     ****                                                                ADDIAG.64
C     ****     S1=T/M                                                     ADDIAG.65
C     ****                                                                ADDIAG.66
      C365=2*C(3)/C(65)                                                   ADDIAG.67
      DO I=1,LEN2                                                         ADDIAG.68
       S1(I,1)=C365*F(I,NTK)/(F(I,NMSK)+F(I,NMSK+1))                      ADDIAG.69
      ENDDO                                                               ADDIAG.70
C     ****                                                                ADDIAG.71
C     ****     Z(1)=ZB                                                    ADDIAG.72
C     ****                                                                ADDIAG.73
      NZK=NJP2+NZ                                                         ADDIAG.74
      EXPT=CDEXP(CI*C(23)*C(4)*DBLE(ITER))                                ADDIAG.75
      DO I=1,LEN1                                                         ADDIAG.76
       F(I,NZK)=DREAL(ZB(J+2)*BND(I)*EXPT)                                ADDIAG.77
      ENDDO                                                               ADDIAG.78
C     ****                                                                ADDIAG.79
C     ****     ADD IN EFFECT OF (1,1) TIDAL COMPONENT                     ADDIAG.80
C     ****                                                                ADDIAG.81
      EXPT=CDEXP(CI*.5*C(23)*C(4)*DBLE(ITER))                             ADDIAG.82
      DO I=1,LEN1                                                         ADDIAG.83
       F(I,NZK)=F(I,NZK)+DREAL(ZB2(J+2)*BND2(I)*EXPT)                     ADDIAG.84
      ENDDO                                                               ADDIAG.85
C     ****                                                                ADDIAG.86
C     ****     ADD IN EFFECT OF ANNUAL TIDAL COMPONENT                    ADDIAG.87
C     ****                                                                ADDIAG.88
      EXPT=(1.,0.)                                                        ADDIAG.89
      DO I=1,LEN1                                                         ADDIAG.90
       F(I,NZK)=F(I,NZK)+DREAL(ZBA(J+2)*BNDA(I)*EXPT)                     ADDIAG.91
      ENDDO                                                               ADDIAG.92
C     ****                                                                ADDIAG.93
C     ****     Z(K+1)=S1(K)+Z(K)                                          ADDIAG.94
C     ****                                                                ADDIAG.95
      DO K=1,KMAX                                                         ADDIAG.96
       DO I=1,LEN1                                                        ADDIAG.97
        F(I,NZK+1)=S1(I,K)+F(I,NZK)                                       ADDIAG.98
       ENDDO                                                              ADDIAG.99
       NZK=NZK+1                                                          ADDIAG.100
      ENDDO                                                               ADDIAG.101
      RETURN                                                              ADDIAG.102
      END                                                                 ADDIAG.103
C                                                                         ADDIAG.104
*DK ADVEC                                                                  ADVEC.1
      SUBROUTINE ADVEC(NX,S)                                               ADVEC.2
      INCLUDE 'param.h'                                                    ADVEC.3
      INCLUDE 'buffe.h'                                                    ADVEC.4
      INCLUDE 'const.h'                                                    ADVEC.5
      INCLUDE 'index.h'                                                    ADVEC.6
      INCLUDE 'phycs.h'                                                    ADVEC.7
      DIMENSION S(ZIMXP,ZKMXP),Z(ZIMXP,ZKMXP),X(ZIMXP,ZKMXP)               ADVEC.8
C     ****                                                                 ADVEC.9
C     ****                   COMPUTE  X = RACS*DL(X)                       ADVEC.10
C     ****                                                                 ADVEC.11
C     ****     X=(C(10)*(X(I+1)-X(I-1))*U(I+1)+U(I-1))/2)-                 ADVEC.12
C     ****       (C(11)*(X(I+2)-X(I-2))*U(I+2)+U(I-2))/2)                  ADVEC.13
C     ****                                                                 ADVEC.14
      NUK=NJ+NU-1                                                          ADVEC.15
      NXK=NJ+NX-1                                                          ADVEC.16
      DO K=1,KMAX                                                          ADVEC.17
       NUK=NUK+1                                                           ADVEC.18
       NXK=NXK+1                                                           ADVEC.19
       DO I=3,IMAXP2                                                       ADVEC.20
        D2X=(F(I+1,NXK)-F(I-1,NXK))*(F(I+1,NUK)+F(I-1,NUK))*C(10)*0.5      ADVEC.21
        D4X=(F(I+2,NXK)-F(I-2,NXK))*(F(I+2,NUK)+F(I-2,NUK))*C(11)*0.5      ADVEC.22
        X(I,K)=(D2X-D4X)*RACS                                              ADVEC.23
       ENDDO                                                               ADVEC.24
      ENDDO                                                                ADVEC.25
C     ****                                                                 ADVEC.26
C     ****                   COMPUTE  C(52)*DP(X)                          ADVEC.27
C     ****                                                                 ADVEC.28
C     ****     Z=(C(12)*(X(J+1)-X(J-1))*V(J+1)+V(J-1))/2)-                 ADVEC.29
C     ****       (C(13)*(X(J+2)-X(J-2))*V(J+2)+V(J-2))/2)                  ADVEC.30
C     ****                                                                 ADVEC.31
      NVJP1K=NJP1+NV-1                                                     ADVEC.32
      NVJM1K=NJM1+NV-1                                                     ADVEC.33
      NXJP1K=NJP1+NX-1                                                     ADVEC.34
      NXJM1K=NJM1+NX-1                                                     ADVEC.35
      NVJP2K=NJP2+NV-1                                                     ADVEC.36
      NVJM2K=NJM2+NV-1                                                     ADVEC.37
      NXJP2K=NJP2+NX-1                                                     ADVEC.38
      NXJM2K=NJM2+NX-1                                                     ADVEC.39
      DO K=1,KMAX                                                          ADVEC.40
       NVJP1K=NVJP1K+1                                                     ADVEC.41
       NVJM1K=NVJM1K+1                                                     ADVEC.42
       NXJP1K=NXJP1K+1                                                     ADVEC.43
       NXJM1K=NXJM1K+1                                                     ADVEC.44
       NVJP2K=NVJP2K+1                                                     ADVEC.45
       NVJM2K=NVJM2K+1                                                     ADVEC.46
       NXJP2K=NXJP2K+1                                                     ADVEC.47
       NXJM2K=NXJM2K+1                                                     ADVEC.48
       DO I=3,IMAXP2                                                       ADVEC.49
        D2X=(F(I,NXJP1K)-F(I,NXJM1K))*(F(I,NVJP1K)+F(I,NVJM1K))*C(12)*     ADVEC.50
     1      0.5                                                            ADVEC.51
        D4X=(F(I,NXJP2K)-F(I,NXJM2K))*(F(I,NVJP2K)+F(I,NVJM2K))*C(13)*     ADVEC.52
     1      0.5                                                            ADVEC.53
        Z(I,K)=(D2X-D4X)*C(52)                                             ADVEC.54
       ENDDO                                                               ADVEC.55
      ENDDO                                                                ADVEC.56
C     ****                                                                 ADVEC.57
C     ****                   S = X+D2X = ADVEC(X)                          ADVEC.58
C     ****                                                                 ADVEC.59
      DO K=1,KMAX                                                          ADVEC.60
       DO I=3,IMAXP2                                                       ADVEC.61
        S(I,K)=X(I,K)+Z(I,K)                                               ADVEC.62
       ENDDO                                                               ADVEC.63
       DO I=1,2                                                            ADVEC.64
        S(I,K)=S(I+IMAX,K)                                                 ADVEC.65
        S(I+IMAXP2,K)=S(I+2,K)                                             ADVEC.66
       ENDDO                                                               ADVEC.67
      ENDDO                                                                ADVEC.68
      RETURN                                                               ADVEC.69
      END                                                                  ADVEC.70
C                                                                          ADVEC.71
*DK ADVECL                                                                ADVECL.1
      SUBROUTINE ADVECL(NX,S,K)                                           ADVECL.2
      INCLUDE 'param.h'                                                   ADVECL.3
      INCLUDE 'buffe.h'                                                   ADVECL.4
      INCLUDE 'const.h'                                                   ADVECL.5
      INCLUDE 'index.h'                                                   ADVECL.6
      INCLUDE 'phycs.h'                                                   ADVECL.7
      DIMENSION S(1)                                                      ADVECL.8
      NUK=NJ+NU+(K-1)                                                     ADVECL.9
      NXJP2K=NJP2+NX                                                      ADVECL.10
      NXJP1K=NJP1+NX                                                      ADVECL.11
      NXK=NJ+NX                                                           ADVECL.12
      NXJM1K=NJM1+NX                                                      ADVECL.13
      NXJM2K=NJM2+NX                                                      ADVECL.14
      NVK=NV+K-1                                                          ADVECL.15
      NVJP2K=NJP2+NVK                                                     ADVECL.16
      NVJP1K=NJP1+NVK                                                     ADVECL.17
      NVJM1K=NJM1+NVK                                                     ADVECL.18
      NVJM2K=NJM2+NVK                                                     ADVECL.19
      DO I=3,IMAXP2                                                       ADVECL.20
       S(I)=.5*RACS*(C(10)*(F(I+1,NXK)-F(I-1,NXK))*(F(I+1,NUK)+F(I-1,     ADVECL.21
     1      NUK))-C(11)*(F(I+2,NXK)-F(I-2,NXK))*(F(I+2,NUK)+F(I-2,NUK)))  ADVECL.22
     2      +.5*C(52)*(C(12)*(F(I,NXJP1K)-F(I,NXJM1K))*(F(I,NVJP1K)+      ADVECL.23
     3      F(I,NVJM1K))-C(13)*(F(I,NXJP2K)-F(I,NXJM2K))*(F(I,NVJP2K)+    ADVECL.24
     4      F(I,NVJM2K)))                                                 ADVECL.25
      ENDDO                                                               ADVECL.26
      RETURN                                                              ADVECL.27
      END                                                                 ADVECL.28
C                                                                         ADVECL.29
*DK ADVECV                                                                ADVECV.1
      SUBROUTINE ADVECV(NX,S,T)                                           ADVECV.2
      INCLUDE 'param.h'                                                   ADVECV.3
      INCLUDE 'vscrw.h'                                                   ADVECV.4
      INCLUDE 'const.h'                                                   ADVECV.5
      INCLUDE 'index.h'                                                   ADVECV.6
      INCLUDE 'buffe.h'                                                   ADVECV.7
      INCLUDE 'phycs.h'                                                   ADVECV.8
      DIMENSION S(ZIMXP,ZKMXP)                                            ADVECV.9
      DIMENSION T(ZIMXP)                                                  ADVECV.10
      NWK=NJNP+NW                                                         ADVECV.11
      NXK=NJ+NX                                                           ADVECV.12
C     ****                                                                ADVECV.13
C     ****     S3(1)=(NX(1)-T)*W(1)*2.                                    ADVECV.14
C     ****                                                                ADVECV.15
      DO I=1,LEN1                                                         ADVECV.16
       S3(I,1)=2.*(F(I,NXK)-T(I))*F(I,NWK)                                ADVECV.17
      ENDDO                                                               ADVECV.18
      DSIG=.5*C(20)                                                       ADVECV.19
      DO I=1,LEN1                                                         ADVECV.20
       S3(I,KMAXP1)=0.                                                    ADVECV.21
      ENDDO                                                               ADVECV.22
C     ****                                                                ADVECV.23
C     ****     S3(K)=(X(K)-X(K-1))*W(K)                                   ADVECV.24
C     ****                                                                ADVECV.25
      DO I=1,LEN2-LEN1                                                    ADVECV.26
       S3(I,2)=(F(I,NXK+1)-F(I,NXK))*F(I,NWK+1)                           ADVECV.27
      ENDDO                                                               ADVECV.28
C     ****                                                                ADVECV.29
C     ****     S3(K)=(S3(K)+S3(K+1))*DSIG                                 ADVECV.30
C     ****                                                                ADVECV.31
      DO I=1,LEN2                                                         ADVECV.32
       S3(I,1)=(S3(I,1)+S3(I,2))*DSIG                                     ADVECV.33
      ENDDO                                                               ADVECV.34
C     ****                                                                ADVECV.35
C     ****     S=S+S3                                                     ADVECV.36
C     ****                                                                ADVECV.37
      DO I=1,LEN2                                                         ADVECV.38
       S(I,1)=S(I,1)+S3(I,1)                                              ADVECV.39
      ENDDO                                                               ADVECV.40
C     ****                                                                ADVECV.35
C     ****     Periodic Points for S                                      ADVECV.36
C     ****                                                                ADVECV.37
      DO I=1,2                                                            ADVECV.38
       DO K=1,KMAX                                                        ADVECV.39
        S(I,K)=S(I+IMAX,K)                                                ADVECV.40
        S(I+IMAXp2,K)=S(I+2,K)                                            ADVECV.41
       ENDDO                                                              ADVECV.42
      ENDDO                                                               ADVECV.43
      RETURN                                                              ADVECV.44
      END                                                                 ADVECV.45
C                                                                         ADVECV.46
*DK ADVNCE                                                                ADVNCE.1
      SUBROUTINE ADVNCE                                                   ADVNCE.2
C     ****                                                                ADVNCE.3
C     ****     ADVANCES THE MODEL IN TIME                                 ADVNCE.4
C     ****                                                                ADVNCE.5
      INCLUDE 'param.h'                                                   ADVNCE.6
      INCLUDE 'vscrw.h'                                                   ADVNCE.7
      INCLUDE 'buffe.h'                                                   ADVNCE.8
      INCLUDE 'const.h'                                                   ADVNCE.9
      INCLUDE 'index.h'                                                   ADVNCE.10
      INCLUDE 'start.h'                                                   ADVNCE.11
      INCLUDE 'phycs.h'                                                   ADVNCE.12
      INCLUDE 'nestcnt.h'                                                   ADVNCE.12
      COMMON/N1INI/INITIAL,INIINPUT                                         MAIN.7
      WRITE(6,5) ITER                                                     ADVNCE.13
    5 FORMAT(1H0,17X,'ADVANCE ENTERED AT ITER ',I6)                       ADVNCE.14
C     ****                                                                ADVNCE.15
C     ****     INITIALIZE BUFFER INDICES                                  ADVNCE.16
C     ****                                                                ADVNCE.17
      MODULO=8                                                            ADVNCE.18
      CALL INIT                                                           ADVNCE.19
C     ****                                                                ADVNCE.20
C     ****     TIME LOOP                                                  ADVNCE.21
C     ****                                                                ADVNCE.22
  100 CONTINUE                                                            ADVNCE.23
      ITER=ITER+1                                                         ADVNCE.24
      write(6,*)iter
C     ****                                                                ADVNCE.473
C     ****     CHECK FOR NESTED GRID INITIALIZATION AT FIRST TIME STEP    ADVNCE.474
C     ****                                                                ADVNCE.475
      IF(INIINPUT.EQ.0)THEN
       ITERN=ITER-1
       IF(NEST.EQ.1.AND.ITERN.GE.NES(1).AND.ITERN.LE.NEE(1))THEN
        LEVEL=1
        IF(MHIST(1).EQ.1)THEN                                                MAIN.20
C        ****                                                                MAIN.21
C        ****     READ HISTORY FILE FOR THIS LEVEL OF NESTED GRID            MAIN.22
C        ****                                                                MAIN.23
         CALL N1HISTRD(LEVEL)                                                MAIN.24
        ELSE                                                                 MAIN.25
C        ****                                                                MAIN.26
C        ****     INTERPOLATE COARSE GRID VALUES FOR THE NESTED GRID         MAIN.27
C        ****                                                                MAIN.28
         CALL N1HISTIN(LEVEL)                                                MAIN.29
        ENDIF                                                                MAIN.30
        INIINPUT=1
       ENDIF 
      ENDIF
C     ****                                                                ADVNCE.25
C     ****     FIND UT TIME  (MODEL DAY = UT DAY, 11/89)                  ADVNCE.26
C     ****                                                                ADVNCE.27
      SECS=DMOD(DBLE(ITER)*C(4),86400.D0)                                 ADVNCE.32
      CALL SUN                                                            ADVNCE.29
      SECS=DBLE(ITER)*C(4)                                                ADVNCE.28
      CALL TAIL(SECS)                                                     ADVNCE.30
      IHIS=IHIS-1                                                         ADVNCE.31
C     ****                                                                ADVNCE.180
C     ****     CALCULATE ION DRIFT VELOCITIES                             ADVNCE.181
C     ****                                                                ADVNCE.182
      CALL VDRIFT                                                         ADVNCE.36
C     ****                                                                ADVNCE.32
C     ****     BEGIN SWEEP OF MESH FROM SOUTH TO NORTH                    ADVNCE.33
C     ****     BRING IN LINE 1                                            ADVNCE.34
C     ****                                                                ADVNCE.35
      CALL FLIP                                                           ADVNCE.37
      DO I=1,IMAXP4*(KMAXP1*NHIST+1)                                      ADVNCE.38
       F(I,NJIN)=G(I,1,1)                                                 ADVNCE.39
      ENDDO                                                               ADVNCE.40
C     ****                                                                ADVNCE.41
C     ****     BRING IN LINES 2 AND 3                                     ADVNCE.42
C     ****     AND REARRANGE LINES 1 AND 2                                ADVNCE.43
C     ****     TO FORM LINES 0 AND -1                                     ADVNCE.44
C     ****                                                                ADVNCE.45
      DO JP2=1,2                                                          ADVNCE.46
       CALL FLIP                                                          ADVNCE.47
       DO I=1,IMAXP4*(KMAXP1*NHIST)+1                                     ADVNCE.48
        F(I,NJIN)=G(I,1,JP2+1)                                            ADVNCE.49
       ENDDO                                                              ADVNCE.50
C      ****                                                               ADVNCE.51
C      ****     ADD DIAGNOSTIC QUANTITIES ONTO LINE JP2                   ADVNCE.52
C      ****                                                               ADVNCE.53
       J=JP2-2                                                            ADVNCE.54
       CALL ADDIAG                                                        ADVNCE.55
C      ****                                                               ADVNCE.56
C      ****     REARRANGE LINE JP2 TO GET LINE -JP2+1                     ADVNCE.57
C      ****                                                               ADVNCE.58
       NJPUT=NJP1                                                         ADVNCE.59
       IF(JP2.EQ.2) NJPUT=NJM1                                            ADVNCE.60
C      ****                                                               ADVNCE.61
C      ****     CONSTRUCT LINES -1,0 FOR GLOBAL CASE                      ADVNCE.62
C      ****                                                               ADVNCE.63
       ILIM=IMAXH+2                                                       ADVNCE.64
       DO N=1,NFLDS                                                       ADVNCE.65
C       ****                                                              ADVNCE.66
C       ****     CHECK IF FIELD IS NEEDED ACROSS POLE                     ADVNCE.67
C       ****                                                              ADVNCE.68
        IF(KPOLE(N).NE.0.)THEN                                            ADVNCE.69
C        ****                                                             ADVNCE.70
C        ****     DETERMINE LENGTH OF FIELD                               ADVNCE.71
C        ****                                                             ADVNCE.72
         IF(KFLDS(N).EQ.2)THEN                                            ADVNCE.73
          KLIM=KMAX                                                       ADVNCE.74
          LEN=LEN2                                                        ADVNCE.75
         ELSE IF(KFLDS(N).GT.2)THEN                                       ADVNCE.76
          KLIM=KMAXP1                                                     ADVNCE.77
          LEN=LEN3                                                        ADVNCE.78
         ELSE                                                             ADVNCE.79
          KLIM=1                                                          ADVNCE.80
          LEN=LEN1                                                        ADVNCE.81
         ENDIF                                                            ADVNCE.82
C        ****                                                             ADVNCE.83
C        ****     SET POINTERS TO INPUT AND OUTPUT BUFFERS                ADVNCE.84
C        ****                                                             ADVNCE.85
         NXK=NJP2+NDEXA(N+1)                                              ADVNCE.86
         NYK=NJPUT+NDEXA(N+1)                                             ADVNCE.87
C        ****                                                             ADVNCE.88
C        ****     CHECK IF FIELD IS TO HAVE SIGN CHANGED                  ADVNCE.89
C        ****                                                             ADVNCE.90
         IF(KPOLE(N).EQ.-1)THEN                                           ADVNCE.91
C         ****                                                            ADVNCE.92
C         ****     CHANGE SIGN                                            ADVNCE.93
C         ****                                                            ADVNCE.94
          DO K=1,KLIM                                                     ADVNCE.95
           ID=IMAXH+1                                                     ADVNCE.96
           DO I=1,ILIM                                                    ADVNCE.97
            F(ID+2,NYK)=-F(I+2,NXK)                                       ADVNCE.98
            F(I   ,NYK)=-F(ID ,NXK)                                       ADVNCE.99
            ID=ID+1                                                       ADVNCE.100
           ENDDO                                                          ADVNCE.101
           NXK=NXK+1                                                      ADVNCE.102
           NYK=NYK+1                                                      ADVNCE.103
          ENDDO                                                           ADVNCE.104
         ELSE IF(KPOLE(N).EQ.1)THEN                                       ADVNCE.105
C         ****                                                            ADVNCE.106
C         ****     DO NOT CHANGE SIGN                                     ADVNCE.107
C         ****                                                            ADVNCE.108
          DO K=1,KLIM                                                     ADVNCE.109
           ID=IMAXH+1                                                     ADVNCE.110
           DO I=1,ILIM                                                    ADVNCE.111
            F(ID+2,NYK)=F(I+2,NXK)                                        ADVNCE.112
            F(I   ,NYK)=F(ID ,NXK)                                        ADVNCE.113
            ID=ID+1                                                       ADVNCE.114
           ENDDO                                                          ADVNCE.115
           NXK=NXK+1                                                      ADVNCE.116
           NYK=NYK+1                                                      ADVNCE.117
          ENDDO                                                           ADVNCE.118
         ENDIF                                                            ADVNCE.119
        ENDIF                                                             ADVNCE.120
       ENDDO                                                              ADVNCE.121
      ENDDO                                                               ADVNCE.122
C     ****                                                                ADVNCE.123
C     ****     CHANGE BUFFER POINTERS SO THAT LINE J IS -2                ADVNCE.124
C     ****     SO THAT INITIALIZATION CALLS TO HDIF CAN BE MADE.          ADVNCE.125
C     ****                                                                ADVNCE.126
      DO J=1,5                                                            ADVNCE.127
       CALL FLIP                                                          ADVNCE.129
      ENDDO                                                               ADVNCE.129
C     ****                                                                ADVNCE.130
C     ****     ITITIALIZE HORIZONTAL DIFFUSION QUANTITIES                 ADVNCE.131
C     ****                                                                ADVNCE.132
      DO JJ=1,3                                                           ADVNCE.133
       CALL FLIP                                                          ADVNCE.134
       J=JJ-3                                                             ADVNCE.135
       CALL HDIF                                                          ADVNCE.136
      ENDDO                                                               ADVNCE.137
C     ****                                                                ADVNCE.138
C     ****     GENERAL LINE LOOP (LATITUDINAL VARIATION)                  ADVNCE.139
C     ****                                                                ADVNCE.140
      DO 3000 J=1,JMAX                                                    ADVNCE.141
      RACS=1./(C(51)*CS(J))                                               ADVNCE.142
      CALL FLIP                                                           ADVNCE.143
C     ****                                                                ADVNCE.144
C     ****     START IN NEXT LINE NORTH                                   ADVNCE.145
C     ****                                                                ADVNCE.146
      IF(J.LT.JMAXM2) THEN                                                ADVNCE.147
       DO I=1,IMAXP4*(KMAXP1*NHIST+1)                                       ADVNCE.148
        F(I,NJIN)=G(I,1,J+3)                                              ADVNCE.149
       ENDDO                                                              ADVNCE.150
      END IF                                                              ADVNCE.151
C     ****                                                                ADVNCE.152
C     ****     START OUT PREVIOUS LINE SOUTH                              ADVNCE.153
C     ****                                                                ADVNCE.154
      IF(J.NE.1)THEN                                                      ADVNCE.155
       DO I=1,IMAXP4*(KMAXP1*NHIST+1)                                       ADVNCE.156
        G(I,1,J-1)=F(I,NJOT)                                              ADVNCE.157
       ENDDO                                                              ADVNCE.158
      ENDIF                                                               ADVNCE.159
C     ****                                                                ADVNCE.160
C     ****     ADD DIAGNOSTIC QUANTITIES ONTO LINE J+2                    ADVNCE.161
C     ****                                                                ADVNCE.162
      IF(J.LE.JMAXM2)CALL ADDIAG                                          ADVNCE.163
      IF(J.EQ.JMAX) IFRST=1                                               ADVNCE.164
C     ******************************************************************  ADVNCE.165
C     ****                                                                ADVNCE.166
C     ****                   DYNAMICS                                     ADVNCE.167
C     ****                                                                ADVNCE.168
C     ******************************************************************  ADVNCE.169
C     ****                                                                ADVNCE.170
C     ****    CALL TO BNDCMP SHOULD LEAD CALLS IN DYNAMICS SECTION OF     ADVNCE.171
C     ****      ADVNCE TO ENSURE THAT MATRICES B(ZIMXP,2,2) AND VECTORS   ADVNCE.172
C     ****      FB(ZIMXP,2) ARE AVAILABLE WHEN NEEDED                     ADVNCE.173
C     ****                                                                ADVNCE.174
      CALL BNDCMP                                                         ADVNCE.175
C     ****                                                                ADVNCE.176
C     ****    CALCULATE W AT N*DT                                         ADVNCE.177
C     ****                                                                ADVNCE.178
      CALL SWDOT                                                          ADVNCE.179
C     ****                                                                ADVNCE.184
C     ****     CALCULATE CP, KT, AND KM                                   ADVNCE.185
C     ****                                                                ADVNCE.186
      CALL CPKTKM                                                         ADVNCE.187
C     ****                                                                ADVNCE.188
C     ****      CLEAR NQO2P, NQOP, NQN2P, NQNOP, NQNP                     ADVNCE.189
C     ****                                                                ADVNCE.190
      NQPK=NQO2P                                                          ADVNCE.191
      DO I=1,5*LEN3                                                       ADVNCE.192
       F(I,NQPK)=0.                                                       ADVNCE.193
      ENDDO                                                               ADVNCE.194
C     ****                                                                ADVNCE.195
C     ****     CALCULATE COLUMN NUMBER DENSITIES                          ADVNCE.196
C     ****                                                                ADVNCE.197
      CALL CHAPMN                                                         ADVNCE.198
C     ****                                                                ADVNCE.199
C     ****     CALCULATE SOLAR HEATING                                    ADVNCE.200
C     ****     CALCULATE REACTION RATES                                   ADVNCE.201
C     ****                                                                ADVNCE.202
      CALL RATES                                                          ADVNCE.203
      CALL QRJ                                                            ADVNCE.204
C     ****                                                                ADVNCE.205
C     ****     CALCULATE BACKGROUND (NIGHT-TIME) IONIZATION               ADVNCE.206
C     ****                                                                ADVNCE.207
      CALL QINITE                                                         ADVNCE.208
C     ****                                                                ADVNCE.209
C     ****     ADD IONIZATION DUE TO SOLAR X-RAYS                         ADVNCE.210
C     ****                                                                ADVNCE.211
      CALL XRAY                                                           ADVNCE.212
C     ****                                                                ADVNCE.213
C     ****     GENERATE AURORAL FIELDS, UI, VI, WI.  FIELDS RETURNED      ADVNCE.214
C     ****     IN T1 THRU T7                                              ADVNCE.215
C     ****                                                                ADVNCE.216
      CALL HEELIS                                                         ADVNCE.217
C     ****                                                                ADVNCE.218
C     ****     CALCULATE AURORAL ADDITIONS TO IONIZATION RATES            ADVNCE.219
C     ****                                                                ADVNCE.220
      CALL ORORA                                                          ADVNCE.221
C     ****                                                                ADVNCE.222
C     ****     SOLVE FOR N(O+)                                            ADVNCE.223
C     ****     SET FLUX AT UPPER BOUNDARY                                 ADVNCE.224
C     ****                                                                ADVNCE.225
      CALL OPFLUX                                                         ADVNCE.226
      CALL OPLUS                                                          ADVNCE.227
C     ****                                                                ADVNCE.228
C     ****     COMPUTE ELECTRON DENSITY, N(E), AND ION NUMBER DENSITIES,  ADVNCE.229
C     ****     N(O2+), N(N2+), N(NO+), N(N+)                              ADVNCE.230
C     ****                                                                ADVNCE.231
      CALL ELDEN                                                          ADVNCE.232
C     ****                                                                ADVNCE.233
C     ****     ION-DRAG PARAMETERS, LXX, LYY, LXY (IN DIPOLE COORDINATE   ADVNCE.234
C     ****     SYSTEM)                                                    ADVNCE.235
C     ****                                                                ADVNCE.236
      CALL LAMDAS                                                         ADVNCE.237
C     ****                                                                ADVNCE.238
C     ****     ROTATE LAMDAS TO GEOGRAPHIC SYSTEM                         ADVNCE.339
C     ****                                                                ADVNCE.340
      CALL ROTATE                                                         ADVNCE.341
C     ****                                                                ADVNCE.342
C     ****     ELECTRON PRODUCTION OF N4S AND N2D                         ADVNCE.343
C     ****                                                                ADVNCE.344
      CALL QTIEFF                                                         ADVNCE.345
C     ****                                                                ADVNCE.346
C     ****     ODD NITROGEN CHEMISTRY                                     ADVNCE.347
C     ****                                                                ADVNCE.348
      CALL CMPN2D                                                         ADVNCE.349
      CALL CMPN4S                                                         ADVNCE.350
      CALL CMPNO                                                          ADVNCE.351
      CALL CMPO2O                                                         ADVNCE.352
C     ****                                                                ADVNCE.353
C     ****     HEATING AND O2 DISSOCIATION DUE TO ODD NITROGEN AND ION    ADVNCE.354
C     ****     CHEMISTRY                                                  ADVNCE.355
C     ****                                                                ADVNCE.356
      CALL QJNNO                                                          ADVNCE.357
      CALL QJION                                                          ADVNCE.358
C     ****                                                                ADVNCE.359
C     ****     CALCULATE ELECTRON AND ION TEMPERATURES                    ADVNCE.360
C     ****                                                                ADVNCE.361
      CALL SETTEI                        !not calculate the temperatures  ADVNCE.362
C     ****                                                                ADVNCE.363
C     ****     CALCULATE IMPLICIT AND EXPLICIT COOLING TERMS IN NWTI      ADVNCE.364
C     ****     AND NWTE                                                   ADVNCE.365
C     ****                                                                ADVNCE.366
      CALL NEWTON                                                         ADVNCE.367
C     ****                                                                ADVNCE.368
C     ****     ADD IN O3P COOLING                                         ADVNCE.369
C     ****                                                                ADVNCE.370
      CALL NEWTO3P                                                        ADVNCE.371
C     ****                                                                ADVNCE.372
C     ****     CALCULATE FLF, FPH, NQDH, NKMH, NPSDH, NPSDH2              ADVNCE.373
C     ****     AT (N-1)*DT                                                ADVNCE.374
C     ****                                                                ADVNCE.375
      CALL HDIF                                                           ADVNCE.376
C     ****                                                                ADVNCE.377
C     ****     ADVANCE T, U, V BY ONE TIME STEP                           ADVNCE.378
C     ****                                                                ADVNCE.379
      CALL DT                                                             ADVNCE.380
      CALL DUV                                                            ADVNCE.381
C     ****                                                                ADVNCE.382
C     ****     COMPOSITION OF MAJOR SPECIES                               ADVNCE.383
C     ****                                                                ADVNCE.384
      CALL COMP                                                           ADVNCE.385
C     ******************************************************************  ADVNCE.386
C     ****                                                                ADVNCE.387
C     ****                   END OF DYNAMICS                              ADVNCE.388
C     ****                                                                ADVNCE.389
C     ******************************************************************  ADVNCE.390
C     ****
C     ****     ASSIGN BOUNDARY VALUES FOR NESTED GRIDS
C     ****
      ITERN=ITER-1
      IF(NEST.EQ.1.AND.ITERN.GE.NES(1).AND.ITERN.LE.NEE(1))THEN
       CALL N1BNDRY(J)
      ENDIF
C     ****                                                                ADVNCE.391
C     ****     CHECK IF ON LINE JMAXM2 OR JMAXM1                          ADVNCE.392
C     ****                                                                ADVNCE.393
      IF(J.GE.JMAXM2.AND.J.LT.JMAX)THEN                                   ADVNCE.394
C      ****                                                               ADVNCE.395
C      ****     REARRANGE LINE NJGET TO GET LINE NJIN                     ADVNCE.396
C      ****                                                               ADVNCE.397
       NJGET=NJP2                                                         ADVNCE.398
       IF(J.EQ.JMAXM1) NJGET=NJ                                           ADVNCE.399
       ILIM=IMAXH+2                                                       ADVNCE.400
       DO N=1,NFLDS                                                       ADVNCE.401
C       ****                                                              ADVNCE.402
C       ****                   CHECK IF FIELD IS NEEDED ACROSS POLE       ADVNCE.403
C       ****                                                              ADVNCE.404
        IF(KPOLE(N).NE.0.)THEN                                            ADVNCE.405
C        ****                                                             ADVNCE.406
C        ****     DETERMINE LENGTH OF FIELD                               ADVNCE.407
C        ****                                                             ADVNCE.408
         IF(KFLDS(N).EQ.2)THEN                                            ADVNCE.409
          KLIM=KMAX                                                       ADVNCE.410
          LEN=LEN2                                                        ADVNCE.411
         ELSE IF(KFLDS(N).EQ.3)THEN                                       ADVNCE.412
          KLIM=KMAXP1                                                     ADVNCE.413
          LEN=LEN3                                                        ADVNCE.414
         ELSE                                                             ADVNCE.415
          KLIM=1                                                          ADVNCE.416
          LEN=LEN1                                                        ADVNCE.417
         ENDIF                                                            ADVNCE.418
C        ****                                                             ADVNCE.419
C        ****                   BRING IN FIELD FROM SCM BUFFER            ADVNCE.420
C        ****                                                             ADVNCE.421
         NXK=NJGET+NDEXA(N+1)                                             ADVNCE.422
         NYK=NJIN+NDEXA(N+1)                                              ADVNCE.423
C        ****                                                             ADVNCE.424
C        ****     CHECK IF FIELD IS TO HAVE SIGN CHANGED                  ADVNCE.425
C        ****                                                             ADVNCE.426
         IF(KPOLE(N).EQ.-1)THEN                                           ADVNCE.427
C         ****                                                            ADVNCE.428
C         ****     CHANGE SIGN                                            ADVNCE.429
C         ****                                                            ADVNCE.430
          DO K=1,KLIM                                                     ADVNCE.431
           ID=IMAXH+1                                                     ADVNCE.432
           DO I=1,ILIM                                                    ADVNCE.433
            F(ID+2,NYK)=-F(I+2,NXK)                                       ADVNCE.434
            F(I   ,NYK)=-F(ID ,NXK)                                       ADVNCE.435
            ID=ID+1                                                       ADVNCE.436
           ENDDO                                                          ADVNCE.437
           NXK=NXK+1                                                      ADVNCE.438
           NYK=NYK+1                                                      ADVNCE.439
          ENDDO                                                           ADVNCE.440
         ELSE IF(KPOLE(N).EQ.1)THEN                                       ADVNCE.441
C         ****                                                            ADVNCE.442
C         ****     DO NOT CHANGE SIGN                                     ADVNCE.443
C         ****                                                            ADVNCE.444
          DO K=1,KLIM                                                     ADVNCE.445
           ID=IMAXH+1                                                     ADVNCE.446
           DO I=1,ILIM                                                    ADVNCE.447
            F(ID+2,NYK)=F(I+2,NXK)                                        ADVNCE.448
            F(I   ,NYK)=F(ID ,NXK)                                        ADVNCE.449
            ID=ID+1                                                       ADVNCE.450
           ENDDO                                                          ADVNCE.451
           NXK=NXK+1                                                      ADVNCE.452
           NYK=NYK+1                                                      ADVNCE.453
          ENDDO                                                           ADVNCE.454
         ENDIF                                                            ADVNCE.455
        ENDIF                                                             ADVNCE.456
       ENDDO                                                              ADVNCE.457
      ENDIF                                                               ADVNCE.458
 3000 CONTINUE                                                            ADVNCE.459
C     ****                                                                ADVNCE.460
C     ****                   TRANSFER LINE JMAX TO DISK                   ADVNCE.461
C     ****                                                                ADVNCE.462
      CALL FLIP                                                           ADVNCE.463
      DO I=1,IMAXP4*(KMAXP1*NHIST+1)                                        ADVNCE.464
       G(I,1,J-1)=F(I,NJOT)                                               ADVNCE.465
      ENDDO                                                               ADVNCE.466
C     ****                                                                ADVNCE.467
C     ****                   SET UP AND SOLVE DYNAMO EQUATION             ADVNCE.468
C     ****                                                                ADVNCE.469
c      CALL DYN2                                                           ADVNCE.470
C     ****                                                                ADVNCE.473
C     ****                   CHECK FOR NESTED GRID MODELING               ADVNCE.474
C     ****                                                                ADVNCE.475
      ITERN=ITER-1
      IF(NEST.EQ.1.AND.ITERN.GE.NES(1).AND.ITERN.LE.NEE(1))THEN
       NLEVEL=1
       CALL N1MAIN(NLEVEL,ITERN,C(4))
C      ****                                                                ADVNCE.471
C      ****                   CHECK FOR TWO-WAY INTERACTION                ADVNCE.472
C      ****                                                                ADVNCE.473
       IF(NFDBK(1).EQ.1)CALL N1FDBK(NLEVEL)
      ENDIF 
C     ****                                                                ADVNCE.467
C     ****                   SET UP AND SOLVE DYNAMO EQUATION             ADVNCE.468
C     ****                                                                ADVNCE.469
      CALL DYN2                                                           ADVNCE.470
C     ****                                                                ADVNCE.471
C     ****                   CHECK FOR EXIT                               ADVNCE.472
C     ****                                                                ADVNCE.473
C     ****                   CHECK FOR HISTORY TAPE WRITE                 ADVNCE.474
C     ****                                                                ADVNCE.475
      IF(IHIS.NE.0)THEN                                                   ADVNCE.476
C      ****                                                               ADVNCE.477
C      ****                   CHECK FOR END OF RUN                        ADVNCE.478
C      ****                                                               ADVNCE.479
       IF(ITER.LT.NSTP) GO TO 100                                         ADVNCE.480
      ENDIF                                                               ADVNCE.481
      WRITE(6,3160) ITER,TIME                                             ADVNCE.482
 3160 FORMAT(1H ,17X,'ADVANCE EXITED  AT ITER = ',I6)                     ADVNCE.483
      RETURN                                                              ADVNCE.484
      END                                                                 ADVNCE.485
C                                                                         ADVNCE.486
*DK AION                                                                    AION.1
      SUBROUTINE AION(SI,SO,LEN)                                            AION.2
      IMPLICIT REAL*8 (A-H,O-Z)                                             AION.3
C     ****                                                                  AION.4
C     ****     CALCULATES INTEGRATED F(X) NEEDED FOR TOTAL AURORAL          AION.5
C     ****     IONIZATION                                                   AION.6
C     ****                                                                  AION.7
C     ****     SI = X, F(X) RETURNED IN SO                                  AION.8
C     ****     LEN = ARRAY LENGTH                                           AION.9
C     ****                                                                  AION.10
      DIMENSION SI(1),SO(1),C(8)                                            AION.11
C     ****                                                                  AION.12
C     ****     CONSTANTS FOR PARAMETERIZATION (ED HSU)                      AION.13
C     ****                                                                  AION.14
      DATA C/3.2333134511131,2.5658873458085,2.2540957232641,               AION.15
     1      0.72971983372673,1.1069072431948,1.7134937681128,               AION.16
     2      1.8835442312993,0.86472135072090/                               AION.17
      DO I=1,LEN                                                            AION.18
       SO(I)=C(1)*SI(I)**C(2)*DEXP(-C(3)*SI(I)**C(4))+                      AION.19
     1       C(5)*SI(I)**C(6)*DEXP(-C(7)*SI(I)**C(8))                       AION.20
      ENDDO                                                                 AION.21
      RETURN                                                                AION.22
      END                                                                   AION.23
C                                                                           AION.24
*DK AURHT                                                                  AURHT.1
      SUBROUTINE AURHT(DLAT,DLON,ALFA,FLUX,DRIZL,ALFA2,FLUX2,IM)           AURHT.2
C     ****                                                                 AURHT.3
C     ****     CALCULATES HORIZONTAL VARIATION OF AURORAL HEAT SOURCE      AURHT.4
C     ****      THIS IS THE NEW VERSION WITH UPDATED ALFA ---- 10/86       AURHT.5
C     ****                                                                 AURHT.6
      INCLUDE 'param.h'                                                    AURHT.7
      INCLUDE 'const.h'                                                    AURHT.8
      COMMON/ANGLE/ALON(ZIMX),COLAT(ZIMX)                                  AURHT.9
      COMMON /IONCR/ISTAR,IHEM,THETA0(2),
     1               DDUUMM(IMAXMP*JMX0+IMX0*JMX0+30)                      AURHT.10
      COMMON /OVALR/ RRAD(2),H0,RH,RROTH,E0,REE,RROTE,FC,ALFAC,FD,ALFAD    AURHT.11
     1, ALFK,ALF6,ALF21,RROT6,RROT21,RD6,RD6V,RD21,RH6,RH21,RT6,RT21       AURHT.12
     2, ALFA0,RALFA,ALFA20,RALFA2,E20,RE2                                  AURHT.13
      DIMENSION DLAT(ZIMX),DLON(ZIMX),ALFA(ZIMX),FLUX(ZIMX),ALFA2          AURHT.14
     1(ZIMX),FLUX2(ZIMX),DRIZL(ZIMX),WK2(ZIMX),WK3(ZIMX),WK1(ZIMX)         AURHT.15
      PI=3.1415926535898                                                   AURHT.16
C     ****                                                                 AURHT.17
C     ****     NEW ALFA (10/86):                                           AURHT.18
C     ****      THE EQUATORWARD DISPLACEMENT OF HARDER ENERGY AROUND       AURHT.19
C     ****         10 MLT IS   RD1=RD1A+RD1V*COS(ALON(I))                  AURHT.20
C     ****                                                                 AURHT.21
      DO I=1,IM                                                            AURHT.22
C      ****                                                                AURHT.23
C      ****     WK1 = COS(LAMDA)                                           AURHT.24
C      ****                                                                AURHT.25
       WK1(I)=DCOS(DATAN2(DSIN(ALON(I)-RROTE),DCOS(ALON(I)-RROTE)))        AURHT.26
C      ****                                                                AURHT.27
C      ****     WK2 = AURORAL HALF WIDTH                                   AURHT.28
C      ****                                                                AURHT.29
       WK2(I)=H0*(1.-RH*DCOS(DATAN2(DSIN(ALON(I)-RROTH),                   AURHT.30
     1        DCOS(ALON(I)-RROTH))) )                                      AURHT.31
C      ****                                                                AURHT.32
C      ****     WK3 = COLAT - RAD                                          AURHT.33
C      ****                                                                AURHT.34
       WK3(I)=COLAT(I)-RRAD(IHEM)                                          AURHT.35
C      ****                                                                AURHT.36
C      ****     ANOTHER NEW ALFA (3/89):                                   AURHT.37
C      ****     ALON IS BETWEEN -180 (0 LT) AND +180.  ROT6 IS AROUND      AURHT.38
C      ****      -90. AND ROT21 IS AROUND 135.  NEED DIFFERENCE 0-180.     AURHT.39
C      ****                                                                AURHT.40
       ALFA(I)=ALFK+ALF6*DEXP(-((WK3(I)-RD6-RD6V*DCOS(ALON(I)))/RH6)**2)   AURHT.41
     1         *DEXP(-(DATAN2(DSIN(ALON(I)-RROT6),DCOS(ALON(I)-RROT6))/    AURHT.42
     2         RT6)**2)+ALF21*DEXP(-((WK3(I)-RD21)/RH21)**2)*              AURHT.43
     3     DEXP(-(DATAN2(DSIN(ALON(I)-RROT21),DCOS(ALON(I)-RROT21))/       AURHT.44
     4         RT21)**2)                                                   AURHT.45
      ENDDO                                                                AURHT.46
      DO I=1,IM                                                            AURHT.47
       FLUX(I)=E0*(1.-REE*WK1(I))*DEXP(-(WK3(I)/WK2(I))**2)                AURHT.48
     1         /(2.*ALFA(I)*1.602D-9)                                      AURHT.49
       DRIZL(I)=DEXP(-((WK3(I) +DABS(WK3(I)))/(2.*H0))**2)                 AURHT.50
       ALFA2(I)=ALFA20*(1.-RALFA2*WK1(I))                                  AURHT.51
       FLUX2(I)=E20*(1.-RE2*WK1(I))*DEXP(-(WK3(I)/WK2(I))**2)              AURHT.52
c     1          /(2*ALFA2(I)*1.602D-9)                                    AURHT.53
      ENDDO                                                                AURHT.54
      RETURN                                                               AURHT.55
      END                                                                  AURHT.56
C                                                                          AURHT.57
*DK BDOTDH                                                                BDOTDH.1
      SUBROUTINE BDOTDH(PHIJM1,PHIJ,PHIJP1,J,ANS)                         BDOTDH.2
C     ****                                                                BDOTDH.3
C     ****      EVALUATES  ANS = (B(H)*DEL(H))*PHI                        BDOTDH.4
C     ****                                                                BDOTDH.5
      INCLUDE 'param.h'                                                   BDOTDH.6
      INCLUDE 'const.h'                                                   BDOTDH.7
      COMMON/MAGFLD/BXM(ZIMXP,2),BX(ZIMXP,ZJMX),BXP(ZIMXP,4),             BDOTDH.8
     1      BY(ZIMXP,ZJMX),BYP(ZIMXP,4),BZ(ZIMXP,ZJMX),BZP(ZIMXP,4),      BDOTDH.9
     2      BMOD(ZIMXP,ZJMX),BMODP(ZIMXP,2)                               BDOTDH.10
      DIMENSION PHIJM1(ZIMXP,ZKMXP),PHIJ(ZIMXP,ZKMXP),                    BDOTDH.11
     A PHIJP1(ZIMXP,ZKMXP),ANS(ZIMXP,ZKMXP)                               BDOTDH.12
      DO K=1,KMAX                                                         BDOTDH.13
       DO I=3,IMAXP2                                                      BDOTDH.14
        ANS(I,K)=1./C(51)*(BX(I,J)/(CS(J)*2.*C(1))*(PHIJ(I+1,K)-          BDOTDH.15
     A           PHIJ(I-1,K))+BY(I,J)*(PHIJP1(I,K)-PHIJM1(I,K))/          BDOTDH.16
     B           (2.*C(2)))                                               BDOTDH.17
       ENDDO                                                              BDOTDH.18
      ENDDO                                                               BDOTDH.19
C     ****                                                                BDOTDH.20
C     ****      PERIODIC POINTS                                           BDOTDH.21
C     ****                                                                BDOTDH.22
      DO I=1,2                                                            BDOTDH.23
       DO K=1,KMAX                                                        BDOTDH.24
        ANS(I,K)=ANS(I+IMAX,K)                                            BDOTDH.25
        ANS(I+IMAXP2,K)=ANS(I+2,K)                                        BDOTDH.26
       ENDDO                                                              BDOTDH.27
      ENDDO                                                               BDOTDH.28
      RETURN                                                              BDOTDH.29
      END                                                                 BDOTDH.30
C                                                                         BDOTDH.31
*DK BDZDVB                                                                BDZDVB.1
      SUBROUTINE BDZDVB(PHI,DVB,H,J,ANS)                                  BDZDVB.2
C     ****                                                                BDZDVB.3
C     ****      EVALUATES  ANS = (BZ*D/(H*DZ)+DIVB)*PHI                   BDZDVB.4
C     ****                                                                BDZDVB.5
      INCLUDE 'param.h'                                                   BDZDVB.6
      INCLUDE 'const.h'                                                   BDZDVB.7
      COMMON/MAGFLD/BXM(ZIMXP,2),BX(ZIMXP,ZJMX),BXP(ZIMXP,4),             BDZDVB.8
     1      BY(ZIMXP,ZJMX),BYP(ZIMXP,4),BZ(ZIMXP,ZJMX),BZP(ZIMXP,4),      BDZDVB.9
     2      BMOD(ZIMXP,ZJMX),BMODP(ZIMXP,2)                               BDZDVB.10
      DIMENSION PHI(ZIMXP,ZKMXP),DVB(ZIMXP),H(ZIMXP,ZKMXP),               BDZDVB.11
     A ANS(ZIMXP,ZKMXP)                                                   BDZDVB.12
      DO K=2,KMAXM1                                                       BDZDVB.13
       DO I=1,LEN1                                                        BDZDVB.14
        ANS(I,K)=BZ(I,J)/(2.*H(I,K)*C(3))*(PHI(I,K+1)-PHI(I,K-1))         BDZDVB.15
     A           +DVB(I)*PHI(I,K)                                         BDZDVB.16
       ENDDO                                                              BDZDVB.17
      ENDDO                                                               BDZDVB.18
C     ****                                                                BDZDVB.19
C     ****      UPPER AND LOWER BOUNDARIES                                BDZDVB.20
C     ****                                                                BDZDVB.21
      DO I=1,LEN1                                                         BDZDVB.22
       ANS(I,KMAX)=BZ(I,J)/(H(I,KMAX)*C(3))*(PHI(I,KMAX)-                 BDZDVB.23
     A             PHI(I,KMAXM1))+DVB(I)*PHI(I,KMAX)                      BDZDVB.24
       ANS(I,1)=BZ(I,J)/(H(I,1)*C(3))*(PHI(I,2)-                          BDZDVB.25
     A          PHI(I,1))+DVB(I)*PHI(I,1)                                 BDZDVB.26
      ENDDO                                                               BDZDVB.27
      RETURN                                                              BDZDVB.28
      END                                                                 BDZDVB.29
C                                                                         BDZDVB.30
*DK BLKTRI                                                                BLKTRI.1
      SUBROUTINE BLKTRI(A,B,C,F,IF,I1,I2,KF,K1,K2,BETA,GAMMA,Y,X)         BLKTRI.2
C     ****                                                                BLKTRI.3
C     ****     This procedure solves (I2-I1+1) tridiagonal block matrix   BLKTRI.4
C     ****     systems in which all blocks are 2 x 2 matrices.            BLKTRI.5
C     ****                                                                BLKTRI.6
C     ****     Each system may be written:                                BLKTRI.7
C     ****                                                                BLKTRI.8
C     ****      A(K) * X(K-1) + B(K) * X(K) + Z(K) * X(K+1) = F(K)        BLKTRI.9
C     ****                                                                BLKTRI.10
C     ****      where:                                                    BLKTRI.11
C     ****                                                                BLKTRI.12
C     ****       K = K1,K2,1                                              BLKTRI.13
C     ****                                                                BLKTRI.14
C     ****       A(K), B(K), C(K) are given (2 x 2) matrices.             BLKTRI.15
C     ****                                                                BLKTRI.16
C     ****       The F(k) are given two componente vectors.               BLKTRI.17
C     ****                                                                BLKTRI.18
C     ****       The system is to be solved for the two component         BLKTRI.19
C     ****       vectors, X(K).                                           BLKTRI.20
C     ****                                                                BLKTRI.21
C     ****       A(K1) = C(K2) = 0.                                       BLKTRI.22
C     ****                                                                BLKTRI.23
C     ****      BETA(K), GAMMA(K), (K = K1,K2,1), are work space for      BLKTRI.24
C     ****      (2 x 2) matrices.                                         BLKTRI.25
C     ****                                                                BLKTRI.26
C     ****      Y(K), (K = K1,K2,1), is work space for two component      BLKTRI.27
C     ****      vectors.                                                  BLKTRI.28
C     ****                                                                BLKTRI.29
C     ****     Algorithm: (See Isaacson and Keller p55)                   BLKTRI.30
C     ****                                                                BLKTRI.31
C     ****      Forward sweep from K = K1 to K = K2:                      BLKTRI.32
C     ****                                                                BLKTRI.33
C     ****       BETA(K1) = B(K1)**(-1)                                   BLKTRI.34
C     ****                                                                BLKTRI.35
C     ****       Y(K1) = BETA(K1)*F(K1)                                   BLKTRI.36
C     ****                                                                BLKTRI.37
C     ****       GAMMA(K) = BETA(K)*C(K),        K = K1,(K2-1),1          BLKTRI.38
C     ****                                                                BLKTRI.39
C     ****       BETA(K) = (B(K) - A(K)*GAMMA(K-1))**(-1),                BLKTRI.40
C     ****                                       K = K1+1,K2,1            BLKTRI.41
C     ****                                                                BLKTRI.42
C     ****       Y(K) = BETA(K)*(F(K) - A(K)*Y(K-1)),                     BLKTRI.43
C     ****                                       K = K1+1,K2,1            BLKTRI.44
C     ****                                                                BLKTRI.45
C     ****      Backward sweep, K = K2,K1,-1                              BLKTRI.46
C     ****                                                                BLKTRI.47
C     ****       X(K2) = Y(K2)                                            BLKTRI.48
C     ****                                                                BLKTRI.49
C     ****       X(K) = Y(K) - GAMMA(K)*X(K+1),  K = K2-1,K1,-1           BLKTRI.50
C     ****                                                                BLKTRI.51
C     ****     Dimension statements:                                      BLKTRI.52
C     ****                                                                BLKTRI.53
C     ****      Block matrices are dimensioned thus:                      BLKTRI.54
C     ****                                                                BLKTRI.55
C     ****       MATRIX(2,2,IF,KF)                                        BLKTRI.56
C     ****                                                                BLKTRI.57
C     ****      Two component vectors are similarly treated:              BLKTRI.58
C     ****                                                                BLKTRI.59
C     ****       VECTOR(2,IF,KF)                                          BLKTRI.60
C     ****                                                                BLKTRI.61
C     ****     Our block matrix scheme spans the range, (K = K1,K2,1),    BLKTRI.62
C     ****     where (1 .LE. K1 .LT. K2 .LE. KF)                          BLKTRI.63
C     ****                                                                BLKTRI.64
C     ****     Similarly, we are solving (I1-I2+1) systems                BLKTRI.65
C     ****     simultaneously as the index, I, spans the range,           BLKTRI.66
C     ****     (I = I1,I2,1), where (1 .LE. I1 .LT. I2 .LE. IF)           BLKTRI.67
C     ****                                                                BLKTRI.68
C     ****                                                                BLKTRI.69
C     ****     Dimension statements:                                      BLKTRI.70
C     ****                                                                BLKTRI.71
      IMPLICIT REAL*8 (A-H,O-Z)                                           BLKTRI.72
      DIMENSION A(2,2,IF,KF), B(2,2,IF,KF), C(2,2,IF,KF), F(2,IF,KF),     BLKTRI.73
     1  BETA(2,2,IF,KF), GAMMA(2,2,IF,KF), Y(2,IF,KF), X(2,IF,KF)         BLKTRI.74
C     ****                                                                BLKTRI.75
C     ****     Lower boundary at K = K1                                   BLKTRI.76
C     ****                                                                BLKTRI.77
      DO I=I1,I2                                                          BLKTRI.78
C      ****                                                               BLKTRI.79
C      ****     Y(1,I,K1) = determinant(B(K1))                            BLKTRI.80
C      ****                                                               BLKTRI.81
       Y(1,I,K1)=B(1,1,I,K1)*B(2,2,I,K1)-B(1,2,I,K1)*B(2,1,I,K1)          BLKTRI.82
C      ****                                                               BLKTRI.83
C      ****     BETA(K1) = B(K1)**(-1)                                    BLKTRI.84
C      ****                                                               BLKTRI.85
       BETA(1,1,I,K1)=B(2,2,I,K1)/Y(1,I,K1)                               BLKTRI.86
       BETA(1,2,I,K1)=-B(1,2,I,K1)/Y(1,I,K1)                              BLKTRI.87
       BETA(2,1,I,K1)=-B(2,1,I,K1)/Y(1,I,K1)                              BLKTRI.88
       BETA(2,2,I,K1)=B(1,1,I,K1)/Y(1,I,K1)                               BLKTRI.89
C      ****                                                               BLKTRI.90
C      ****     Y(K1) = BETA(K1)*F(K1)                                    BLKTRI.91
C      ****                                                               BLKTRI.92
       Y(1,I,K1)=BETA(1,1,I,K1)*F(1,I,K1)+BETA(1,2,I,K1)*F(2,I,K1)        BLKTRI.93
       Y(2,I,K1)=BETA(2,1,I,K1)*F(1,I,K1)+BETA(2,2,I,K1)*F(2,I,K1)        BLKTRI.94
      ENDDO                                                               BLKTRI.95
C     ****                                                                BLKTRI.96
C     ****     Now deal with levels (K1+1),K2,1                           BLKTRI.97
C     ****                                                                BLKTRI.98
      DO K=K1+1,K2                                                        BLKTRI.99
       DO I=I1,I2                                                         BLKTRI.100
C       ****                                                              BLKTRI.101
C       ****     GAMMA(K-1) = BETA(K-1)*C(K-1)                            BLKTRI.102
C       ****                                                              BLKTRI.103
        GAMMA(1,1,I,K-1)=BETA(1,1,I,K-1)*C(1,1,I,K-1)+                    BLKTRI.104
     1                   BETA(1,2,I,K-1)*C(2,1,I,K-1)                     BLKTRI.105
        GAMMA(1,2,I,K-1)=BETA(1,1,I,K-1)*C(1,2,I,K-1)+                    BLKTRI.106
     1                   BETA(1,2,I,K-1)*C(2,2,I,K-1)                     BLKTRI.107
        GAMMA(2,1,I,K-1)=BETA(2,1,I,K-1)*C(1,1,I,K-1)+                    BLKTRI.108
     1                   BETA(2,2,I,K-1)*C(2,1,I,K-1)                     BLKTRI.109
        GAMMA(2,2,I,K-1)=BETA(2,1,I,K-1)*C(1,2,I,K-1)+                    BLKTRI.110
     1                   BETA(2,2,I,K-1)*C(2,2,I,K-1)                     BLKTRI.111
C         ****                                                            BLKTRI.112
C         ****     GAMMA(K) = B(K) - A(K)*GAMMA(K-1)                      BLKTRI.113
C         ****                                                            BLKTRI.114
        GAMMA(1,1,I,K)=B(1,1,I,K)-A(1,1,I,K)*GAMMA(1,1,I,K-1)-            BLKTRI.115
     1                 A(1,2,I,K)*GAMMA(2,1,I,K-1)                        BLKTRI.116
        GAMMA(1,2,I,K)=B(1,2,I,K)-A(1,1,I,K)*GAMMA(1,2,I,K-1)-            BLKTRI.117
     1                 A(1,2,I,K)*GAMMA(2,2,I,K-1)                        BLKTRI.118
        GAMMA(2,1,I,K)=B(2,1,I,K)-A(2,1,I,K)*GAMMA(1,1,I,K-1)-            BLKTRI.119
     1                 A(2,2,I,K)*GAMMA(2,1,I,K-1)                        BLKTRI.120
        GAMMA(2,2,I,K)=B(2,2,I,K)-A(2,1,I,K)*GAMMA(1,2,I,K-1)-            BLKTRI.121
     1                 A(2,2,I,K)*GAMMA(2,2,I,K-1)                        BLKTRI.122
C       ****                                                              BLKTRI.123
C       ****     Y(1,I,K) = determinant(GAMMA(K))                         BLKTRI.124
C       ****                                                              BLKTRI.125
        Y(1,I,K)=GAMMA(1,1,I,K)*GAMMA(2,2,I,K)-                           BLKTRI.126
     1           GAMMA(1,2,I,K)*GAMMA(2,1,I,K)                            BLKTRI.127
C       ****                                                              BLKTRI.128
C       ****     BETA(K) = GAMMA(K)**(-1)                                 BLKTRI.129
C       ****                                                              BLKTRI.130
        BETA(1,1,I,K)=GAMMA(2,2,I,K)/Y(1,I,K)                             BLKTRI.131
        BETA(1,2,I,K)=-GAMMA(1,2,I,K)/Y(1,I,K)                            BLKTRI.132
        BETA(2,1,I,K)=-GAMMA(2,1,I,K)/Y(1,I,K)                            BLKTRI.133
        BETA(2,2,I,K)=GAMMA(1,1,I,K)/Y(1,I,K)                             BLKTRI.134
C       ****                                                              BLKTRI.135
C       ****     X(K) = F(K) - A(K)*Y(K-1)                                BLKTRI.136
C       ****                                                              BLKTRI.137
        X(1,I,K)=F(1,I,K)-A(1,1,I,K)*Y(1,I,K-1)-                          BLKTRI.138
     1           A(1,2,I,K)*Y(2,I,K-1)                                    BLKTRI.139
        X(2,I,K)=F(2,I,K)-A(2,1,I,K)*Y(1,I,K-1)-                          BLKTRI.140
     1           A(2,2,I,K)*Y(2,I,K-1)                                    BLKTRI.141
C       ****                                                              BLKTRI.142
C       ****     Y(K) = BETA(K)*X(K)                                      BLKTRI.143
C       ****                                                              BLKTRI.144
        Y(1,I,K)=BETA(1,1,I,K)*X(1,I,K)+BETA(1,2,I,K)*X(2,I,K)            BLKTRI.145
        Y(2,I,K)=BETA(2,1,I,K)*X(1,I,K)+BETA(2,2,I,K)*X(2,I,K)            BLKTRI.146
       ENDDO                                                              BLKTRI.147
      ENDDO                                                               BLKTRI.148
C     ****                                                                BLKTRI.149
C     ****     Backward sweep to determine final solution, X(K) for       BLKTRI.150
C     ****     K = K2,K1,-1                                               BLKTRI.151
C     ****                                                                BLKTRI.152
C     ****      X(K2) = Y(K2)                                             BLKTRI.153
C     ****                                                                BLKTRI.154
      DO I=I1,I2                                                          BLKTRI.155
       X(1,I,K2)=Y(1,I,K2)                                                BLKTRI.156
       X(2,I,K2)=Y(2,I,K2)                                                BLKTRI.157
      ENDDO                                                               BLKTRI.158
C     ****                                                                BLKTRI.159
C     ****      X(K) = Y(K) - GAMMA(K)*X(K+1)                             BLKTRI.160
C     ****                                                                BLKTRI.161
      DO K=K2-1,K1,-1                                                     BLKTRI.162
       DO I=I1,I2                                                         BLKTRI.163
        X(1,I,K)=Y(1,I,K)-GAMMA(1,1,I,K)*X(1,I,K+1)-                      BLKTRI.164
     1           GAMMA(1,2,I,K)*X(2,I,K+1)                                BLKTRI.165
        X(2,I,K)=Y(2,I,K)-GAMMA(2,1,I,K)*X(1,I,K+1)-                      BLKTRI.166
     1           GAMMA(2,2,I,K)*X(2,I,K+1)                                BLKTRI.167
       ENDDO                                                              BLKTRI.168
      ENDDO                                                               BLKTRI.169
      RETURN                                                              BLKTRI.170
      END                                                                 BLKTRI.171
C                                                                         BLKTRI.172
*DK BNDCMP                                                                BNDCMP.1
      SUBROUTINE BNDCMP                                                   BNDCMP.2
C     ****                                                                BNDCMP.3
C     ****     CALCULATE MATRICES B(ZIMXP,2,2) AND VECTORS FB(ZIMXP,2)    BNDCMP.4
C     ****       REPRESENTING THE LOWER BOUBNDARY CONDITION IN COMP,      BNDCMP.5
C     ****       WHERE PSI1 AND PSI2 ARE CALCULATED:                      BNDCMP.6
C     ****                                                                BNDCMP.7
C     ****         PSI(K=-1/2) = B * PSI(K=1/2) + FB                      BNDCMP.8
C     ****                                                                BNDCMP.9
C     ****     BNDCMP CALLS THE SUBROUTINE BNDEF TO DEFINE THE 2 X 2      BNDCMP.10
C     ****       MATRICES E, F AND THE 2 VECTOR G IN THE GENERAL          BNDCMP.11
C     ****       LOWER BOUNDARY CONDITION:                                BNDCMP.12
C     ****                                                                BNDCMP.13
C     ****         E * D(PSI)/DS + F * PSI + G = 0.                       BNDCMP.14
C     ****                                                                BNDCMP.15
C     ****         WHERE:                                                 BNDCMP.16
C     ****           PSI = |PSI1| AND THE BOUNDARY CONDITION IS APPLIED   BNDCMP.17
C     ****                 |    |                                         BNDCMP.18
C     ****                 |PSI2|                                         BNDCMP.19
C     ****                                                                BNDCMP.20
C     ****           AT LEVEL ZERO                                        BNDCMP.21
C     ****                                                                BNDCMP.22
C     ****     THIS SUBROUTINE THEN EVALUATES B AND FB FROM:              BNDCMP.23
C     ****                                                                BNDCMP.24
C     ****       B = (E/DS - F/2.)**(-1) * (E/DS + F/2.)                  BNDCMP.25
C     ****                                                                BNDCMP.26
C     ****       FB = (E/DS - F/2.)**(-1) * G                             BNDCMP.27
C     ****                                                                BNDCMP.28
      INCLUDE "param.h"                                                   BNDCMP.29
      INCLUDE "vscrw.h"                                                   BNDCMP.30
      INCLUDE "const.h"                                                   BNDCMP.31
      INCLUDE "index.h"                                                   BNDCMP.32
      INCLUDE "buffe.h"                                                   BNDCMP.33
      INCLUDE "cpbnd.h"                                                   BNDCMP.34
      DIMENSION EE(ZIMXP,2,2),FF(ZIMXP,2,2),GG(ZIMXP,2),WM1(ZIMXP,2,2),   BNDCMP.35
     1  WM2(ZIMXP,2,2),WM3(ZIMXP,2,2),WV1(ZIMXP,2),WS1(ZIMXP)             BNDCMP.36
      EQUIVALENCE (EE,S1),(FF,S2),(GG,S3),(WM1,S4),(WM2,S5),(WM3,S6),     BNDCMP.37
     1  (WV1,S7),(WS1,S8)                                                 BNDCMP.38
C     ****                                                                BNDCMP.39
C     ****     CALL BNDEF TO DEFINE E, F AND G IN S1, S2 AND S3           BNDCMP.40
C     ****                                                                BNDCMP.41
      CALL BNDEF                                                          BNDCMP.42
C     ****                                                                BNDCMP.43
C     ****     WM1 = (E/DS - F/2.)                                        BNDCMP.44
C     ****                                                                BNDCMP.45
C     ****     WM1 = (E/DS + F/2.)                                        BNDCMP.46
C     ****                                                                BNDCMP.47
      DO L=1,2                                                            BNDCMP.48
       DO M=1,2                                                           BNDCMP.49
        DO I=1,LEN1                                                       BNDCMP.50
         WM1(I,L,M)=EE(I,L,M)/C(3)-FF(I,L,M)/2.                           BNDCMP.51
         WM2(I,L,M)=EE(I,L,M)/C(3)+FF(I,L,M)/2.                           BNDCMP.52
        ENDDO                                                             BNDCMP.53
       ENDDO                                                              BNDCMP.54
      ENDDO                                                               BNDCMP.55
C     ****                                                                BNDCMP.56
C     ****     WM3 = WM1**(-1)                                            BNDCMP.57
C     ****                                                                BNDCMP.58
C     ****       WS1 = DET(WM1)                                           BNDCMP.59
C     ****                                                                BNDCMP.60
      DO I=1,LEN1                                                         BNDCMP.61
       WS1(I)=WM1(I,1,1)*WM1(I,2,2)-WM1(I,1,2)*WM1(I,2,1)                 BNDCMP.62
      ENDDO                                                               BNDCMP.63
C     ****                                                                BNDCMP.64
C     ****     NOW INVERSE OF WM1 IN WM3                                  BNDCMP.65
C     ****                                                                BNDCMP.66
      DO I=1,LEN1                                                         BNDCMP.67
       WM3(I,1,1)=WM1(I,2,2)/WS1(I)                                       BNDCMP.68
       WM3(I,1,2)=-WM1(I,1,2)/WS1(I)                                      BNDCMP.69
       WM3(I,2,1)=-WM1(I,2,1)/WS1(I)                                      BNDCMP.70
       WM3(I,2,2)=WM1(I,1,1)/WS1(I)                                       BNDCMP.71
      ENDDO                                                               BNDCMP.72
C     ****                                                                BNDCMP.73
C     ****     B = WM3 * WM2                                              BNDCMP.74
C     ****                                                                BNDCMP.75
      DO L=1,2                                                            BNDCMP.76
       DO M=1,2                                                           BNDCMP.77
        DO I=1,LEN1                                                       BNDCMP.78
         B(I,L,M)=WM3(I,L,1)*WM2(I,1,M)+WM3(I,L,2)*WM2(I,2,M)             BNDCMP.79
        ENDDO                                                             BNDCMP.80
       ENDDO                                                              BNDCMP.81
      ENDDO                                                               BNDCMP.82
C     ****                                                                BNDCMP.83
C     ****     FB = WM3 * G                                               BNDCMP.84
C     ****                                                                BNDCMP.85
      DO L=1,2                                                            BNDCMP.86
       DO I=1,LEN1                                                        BNDCMP.87
        FB(I,L)=WM3(I,L,1)*GG(I,1)+WM3(I,L,2)*GG(I,2)                     BNDCMP.88
       ENDDO                                                              BNDCMP.89
      ENDDO                                                               BNDCMP.90
      RETURN                                                              BNDCMP.91
      END                                                                 BNDCMP.92
C                                                                         BNDCMP.93
*DK BNDEF                                                                 BNDEF.1
      SUBROUTINE BNDEF                                                    BNDEF.2
C     ****                                                                BNDEF.3
C     ****     BNDEF DEFINES THE LOWER BOUNDARY CONDITION FOR THIS        BNDEF.4
C     ****       VERSION OF THE MODEL                                     BNDEF.5
C     ****                                                                BNDEF.6
      INCLUDE "param.h"                                                   BNDEF.7
      INCLUDE "vscrw.h"                                                   BNDEF.8
      INCLUDE "index.h"                                                   BNDEF.9
      INCLUDE "buffe.h"                                                   BNDEF.10
      INCLUDE "phycs.h"                                                   BNDEF.11
      INCLUDE "const.h"                                                   BNDEF.12
C     ****     THE LOWER BOUNDARY CONDITION FOR COMP IS:                  BNDEF.13
C     ****                                                                BNDEF.14
C     ****       E * D(PSI)/DS + F * PSI +G = 0.                          BNDEF.15
C     ****                                                                BNDEF.16
C     ****         WHERE:                                                 BNDEF.17
C     ****           PSI = VECTOR(PSI1,PSI2)                              BNDEF.18
C     ****           E AND F ARE 2 X 2 MATRICES                           BNDEF.19
C     ****           G = VECTOR(G1,G2)                                    BNDEF.20
C     ****                                                                BNDEF.21
C     ****           E, F AND G MAY BE FUNCTIONS OF LATITUDE & LONGITUDE  BNDEF.22
C     ****                                                                BNDEF.23
C     ****       THIS SUBROUTINE DEFINES E, F AND G IN ARRAYS OF /VSCR/   BNDEF.24
C     ****                                                                BNDEF.25
C     ****         S1 IS EQUIVALENT TO E(ZIMXP,2,2)                       BNDEF.26
C     ****         S2 IS EQUIVALENT TO F(ZIMXP,2,2)                       BNDEF.27
C     ****         S3 IS EQUIVALENT TO G(ZIMXP,2)                         BNDEF.28
C     ****                                                                BNDEF.29
      DIMENSION EE(ZIMXP,2,2),FF(ZIMXP,2,2),GG(ZIMXP,2)                   BNDEF.30
      EQUIVALENCE (EE,S1),(FF,S2),(GG,S3)                                 BNDEF.31
C     ****                                                                BNDEF.32
C     ****     IN TIGCM AND TIEGCM:                                       BNDEF.33
C     ****                                                                BNDEF.34
C     ****       E = |0.  0.|                                             BNDEF.35
C     ****           |      |                                             BNDEF.36
C     ****           |0.  1.|                                             BNDEF.37
C     ****                                                                BNDEF.38
C     ****       F = |1.  1.|                                             BNDEF.39
C     ****           |      |                                             BNDEF.40
C     ****           |0. -1.|                                             BNDEF.41
C     ****                                                                BNDEF.42
C     ****       G = |-ALFA|                                              BNDEF.43
C     ****           |     |                                              BNDEF.44
C     ****           |   0.|                                              BNDEF.45
C     ****                                                                BNDEF.46
C     ****       WHERE:                                                   BNDEF.47
C     ****         ALFA = 0.22 + 0.014 = 0.234                            BNDEF.48
C     ****                                                                BNDEF.49
      DATA ALFA/0.234/                                                    BNDEF.50
      DO I=1,LEN1                                                         BNDEF.51
       EE(I,1,1)=0.                                                       BNDEF.52
       EE(I,1,2)=0.                                                       BNDEF.53
       EE(I,2,1)=0.                                                       BNDEF.54
       EE(I,2,2)=1.                                                       BNDEF.55
       FF(I,1,1)=1.                                                       BNDEF.56
       FF(I,1,2)=1.                                                       BNDEF.57
       FF(I,2,1)=0.                                                       BNDEF.58
       FF(I,2,2)=-1.                                                      BNDEF.59
       GG(I,1)=-ALFA                                                      BNDEF.60
       GG(I,2)=0.                                                         BNDEF.61
      ENDDO                                                               BNDEF.62
      RETURN                                                              BNDEF.63
      END                                                                 BNDEF.64
C                                                                         BNDEF.65
*DK CHAPMN                                                                CHAPMN.1
      SUBROUTINE CHAPMN                                                   CHAPMN.2
C     ****                                                                CHAPMN.3
C     ****      CALCULATE LINE INTEGRAL FOR EACH SPECIES AT EACH GRID     CHAPMN.4
C     ****      POINT IN NNO2, NNO, NNN2                                  CHAPMN.5
C     ****                                                                CHAPMN.6
      INCLUDE 'param.h'                                                   CHAPMN.7
      INCLUDE 'vscrw.h'                                                   CHAPMN.8
      INCLUDE 'const.h'                                                   CHAPMN.9
      INCLUDE 'index.h'                                                   CHAPMN.10
      INCLUDE 'buffe.h'                                                   CHAPMN.11
      INCLUDE 'phycs.h'                                                   CHAPMN.12
      INCLUDE 'start.h'                                                   CHAPMN.13
C     ****                                                                CHAPMN.14
C     ****      T1=SOLAR ZENITH ANGLE,CHI                                 CHAPMN.15
C     ****      T2=SIN(CHI)                                               CHAPMN.16
C     ****      T3=COS(CHI)                                               CHAPMN.17
C     ****      T4=SQRT(SIN(CHI))                                         CHAPMN.18
C     ****                                                                CHAPMN.19
      RLAT=-.5d0*C(110)*DBLE(1-NHEMI)+(DBLE(J-1)+.5d0)*C(2)               CHAPMN.20
      COSLAT=DCOS(RLAT)                                                   CHAPMN.21
      SINLAT=DSIN(RLAT)                                                   CHAPMN.22
      DO I=1,LEN1                                                         CHAPMN.23
C      ****                                                               CHAPMN.24
C      ****      T1=LOCAL TIME                                            CHAPMN.25
C      ****                                                               CHAPMN.26
      T1(I)=DMOD(SECS/3600.+(DBLE(I-3)*C(1)+C(110))*12./C(110),24.D0)       CHAPMN.27
C      ****                                                               CHAPMN.28
C      ****      T1=CHI                                                   CHAPMN.29
C      ****                                                               CHAPMN.30
       T1(I)=DACOS(C(95)*SINLAT+C(96)*COSLAT*DCOS(C(110)                  CHAPMN.31
     &       *(T1(I)-12)/12.))                                            CHAPMN.32
       T2(I)=DSIN(T1(I))                                                  CHAPMN.33
       T3(I)=DCOS(T1(I))                                                  CHAPMN.34
       T4(I)=DSQRT(T2(I))                                                 CHAPMN.35
      ENDDO                                                               CHAPMN.36
C     ****                                                                CHAPMN.37
C     ****      S9=RP, ANNUAL TIDES DEFINE LOWER BOUNDARY                 CHAPMN.38
C     ****                                                                CHAPMN.39
      NZK=NJ+NZ                                                           CHAPMN.40
      DO I=1,LEN3                                                         CHAPMN.41
       S9(I,1)=F(I,NZK)+C(51)                                             CHAPMN.42
      ENDDO                                                               CHAPMN.43
C     ****                                                                CHAPMN.44
C     ****      S8=T (INTERPOLATED TO KMAXP1 LEVELS)                      CHAPMN.45
C     ****      LEVEL 1                                                   CHAPMN.46
C     ****                                                                CHAPMN.47
      NTK=NJ+NT+KMAX                                                      CHAPMN.48
      DO I=1,LEN1                                                         CHAPMN.49
       S8(I,1)=F(I,NTK)                                                   CHAPMN.50
      ENDDO                                                               CHAPMN.51
C     ****                                                                CHAPMN.52
C     ****      LEVELS 2 THRU KMAX                                        CHAPMN.53
C     ****                                                                CHAPMN.54
      NTK=NJ+NT-1                                                         CHAPMN.55
      DO K=2,KMAX                                                         CHAPMN.56
       NTK=NTK+1                                                          CHAPMN.57
       DO I=1,LEN1                                                        CHAPMN.58
        S8(I,K)=.5*(F(I,NTK)+F(I,NTK+1))                                  CHAPMN.59
       ENDDO                                                              CHAPMN.60
      ENDDO                                                               CHAPMN.61
C     ****                                                                CHAPMN.62
C     ****      LEVEL KMAXP1                                              CHAPMN.63
C     ****                                                                CHAPMN.64
      NTK=NJ+NT+KMAX-1                                                    CHAPMN.65
      DO I=1,LEN1                                                         CHAPMN.66
       S8(I,KMAXP1)=F(I,NTK)                                              CHAPMN.67
      ENDDO                                                               CHAPMN.68
C     ****                                                                CHAPMN.69
C     ****      SPECIES DO LOOP                                           CHAPMN.70
C     ****                                                                CHAPMN.71
      DO N=1,3                                                            CHAPMN.72
C      ****                                                               CHAPMN.73
C      ****      S7=PSI(N)                                                CHAPMN.74
C      ****                                                               CHAPMN.75
       IF(N.EQ.3)THEN                                                     CHAPMN.76
        NPS1K=NJ+NPS                                                      CHAPMN.77
        NPS2K=NPS1K+KMAXP1                                                CHAPMN.78
        DO I=1,LEN3                                                       CHAPMN.79
         S7(I,1)=1.-F(I,NPS1K)-F(I,NPS2K)                                 CHAPMN.80
         IF(S7(I,1).LT.0.)S7(I,1)=0.                                      CHAPMN.81
        ENDDO                                                             CHAPMN.82
       ELSE                                                               CHAPMN.83
        NPSK=NJ+NPS+(N-1)*KMAXP1                                          CHAPMN.84
        DO I=1,LEN3                                                       CHAPMN.85
         S7(I,1)=F(I,NPSK)                                                CHAPMN.86
         IF(S7(I,1).LT.0.)S7(I,1)=0.                                      CHAPMN.87
        ENDDO                                                             CHAPMN.88
       ENDIF                                                              CHAPMN.89
C      ****                                                               CHAPMN.90
C      ****      S7=NO. DENSITY INTEGRAL                                  CHAPMN.91
C      ****      TOP OF MODEL                                             CHAPMN.92
C      ****      S7(KMAXP1)=N0*P0*PSI(N)*EXPS*MBAR/(RMASS(N)**2*G)        CHAPMN.93
C      ****                                                               CHAPMN.94
       FACTOR=C(85)*C(81)*EXPS(KMAX)*C(86)/(RMASS(N)**2*C(54))            CHAPMN.95
       NMSK=NJ+NMS+KMAX                                                   CHAPMN.96
       DO I=1,LEN1                                                        CHAPMN.97
        S7(I,KMAXP1)=FACTOR*.5*(S7(I,KMAX)+S7(I,KMAXP1))*F(I,NMSK)        CHAPMN.98
       ENDDO                                                              CHAPMN.99
C      ****                                                               CHAPMN.100
C      ****      INTEGRATE DOWN TO LEVEL 1                                CHAPMN.101
C      ****                                                               CHAPMN.102
       DO KK=1,KMAX                                                       CHAPMN.103
        K=KMAXP1-KK                                                       CHAPMN.104
        FACTOR=C(85)*C(81)*EXPS(K)/(RMASS(N)*C(54))*C(3)                  CHAPMN.105
        DO I=1,LEN1                                                       CHAPMN.106
         S7(I,K)=S7(I,K+1)+FACTOR*S7(I,K)                                 CHAPMN.107
        ENDDO                                                             CHAPMN.108
       ENDDO                                                              CHAPMN.109
C      ****                                                               CHAPMN.110
C      ****      COPY VERTICAL COLUMN DENSITIES TO NNVO2, NNVO, NNVN2     CHAPMN.111
C      ****                                                               CHAPMN.112
       NNVK=NNVO2+(N-1)*KMAXP1                                            CHAPMN.113
       DO I=1,LEN3                                                        CHAPMN.114
        F(I,NNVK)=S7(I,1)                                                 CHAPMN.115
       ENDDO                                                              CHAPMN.116
C      ****                                                               CHAPMN.117
C      ****      S6=SQRT(RP/2HP)                                          CHAPMN.118
C      ****                                                               CHAPMN.119
       FACTOR=RMASS(N)*C(54)/(2.*C(57))                                   CHAPMN.120
       DO I=1,LEN3                                                        CHAPMN.121
        S6(I,1)=DSQRT(S9(I,1)*FACTOR/S8(I,1))                             CHAPMN.122
       ENDDO                                                              CHAPMN.123
C      ****                                                               CHAPMN.124
C      ****      S5=YP                                                    CHAPMN.125
C      ****                                                               CHAPMN.126
       DO K=1,KMAXP1                                                      CHAPMN.127
        DO I=1,LEN1                                                       CHAPMN.128
         S5(I,K)=S6(I,K)*DABS(T3(I))                                      CHAPMN.129
        ENDDO                                                             CHAPMN.130
       ENDDO                                                              CHAPMN.131
C      ****                                                               CHAPMN.132
C      ****      S5=IP                                                    CHAPMN.133
C      ****                                                               CHAPMN.134
       DO I=1,LEN3                                                        CHAPMN.135
        IF((S5(I,1)-8.).GE.0.)THEN                                        CHAPMN.136
         S5(I,1)=S7(I,1)*C(112)*S6(I,1)*0.56498823/(0.06651874+S5(I,1))   CHAPMN.137
        ELSE                                                              CHAPMN.138
         S5(I,1)=S7(I,1)*C(112)*S6(I,1)*(1.0606963+0.5564383*S5(I,1))/    CHAPMN.139
     1           ((S5(I,1)+1.7245609)*S5(I,1)+1.0619896)                  CHAPMN.140
        ENDIF                                                             CHAPMN.141
       ENDDO                                                              CHAPMN.142
C      ****                                                               CHAPMN.143
C      ****      S4=2.*IG                                                 CHAPMN.144
C      ****                                                               CHAPMN.145
       FACTOR=C(54)*RMASS(N)/C(57)                                        CHAPMN.146
       DO K=1,KMAXP1                                                      CHAPMN.147
        DO I=1,LEN1                                                       CHAPMN.148
         S4(I,K)=2.*S7(I,K)*DEXP(S9(I,K)*(1.-T2(I))*FACTOR/S8(I,K))       CHAPMN.149
     $           *C(112)*T4(I)*S6(I,K)                                    CHAPMN.150
        ENDDO                                                             CHAPMN.151
       ENDDO                                                              CHAPMN.152
C      ****                                                               CHAPMN.153
C      ****      SN=LINE INTEGRAL  (0.0 IF OBSCURED BY EARTH)             CHAPMN.154
C      ****                                                               CHAPMN.155
       NNK=NNO2+(N-1)*KMAXP1-1                                            CHAPMN.156
       DO K=1,KMAXP1                                                      CHAPMN.157
        NNK=NNK+1                                                         CHAPMN.158
        DO I=1,LEN1                                                       CHAPMN.159
         IF(T3(I).GE.0.)THEN                                              CHAPMN.160
          F(I,NNK)=1.D80                                                  CHAPMN.161
         ELSE                                                             CHAPMN.162
          F(I,NNK)=S4(I,K)-S5(I,K)                                        CHAPMN.163
         ENDIF                                                            CHAPMN.164
         IF((S9(I,K)*T2(I)-C(51)).LT.0.)F(I,NNK)=1.D80                    CHAPMN.165
         IF(T3(I).GE.0.)F(I,NNK)=S5(I,K)                                  CHAPMN.166
        ENDDO                                                             CHAPMN.167
       ENDDO                                                              CHAPMN.168
      ENDDO                                                               CHAPMN.169
      RETURN                                                              CHAPMN.170
      END                                                                 CHAPMN.171
C                                                                         CHAPMN.172
*DK CMPN2D                                                                CMPN2D.1
      SUBROUTINE CMPN2D                                                   CMPN2D.2
C     ****                                                                CMPN2D.3
C     ****     CALCULATES PSI(N2D) ASSUMING PHOTOCHEMICAL EQUILIBRIUM     CMPN2D.4
C     ****     NOTE: THIS IS DIAGNOSTIC.  CALL BEFORE CMPN4S AND CMPNO    CMPN2D.5
C     ****                                                                CMPN2D.6
      INCLUDE 'param.h'                                                   CMPN2D.7
      INCLUDE 'vscrw.h'                                                   CMPN2D.8
      INCLUDE 'const.h'                                                   CMPN2D.9
      INCLUDE 'index.h'                                                   CMPN2D.10
      INCLUDE 'buffe.h'                                                   CMPN2D.11
      INCLUDE 'rates.h'                                                   CMPN2D.12
      COMMON/MASS/RMN4S,RMN2D,RMNO,BRN2D,CEE                              CMPN2D.14
      NPNOK=NJ+NPNO                                                       CMPN2D.15
      NTK=NJ+NT                                                           CMPN2D.16
      NPS1K=NJ+NPS                                                        CMPN2D.17
      NPS2K=NPS1K+KMAXP1                                                  CMPN2D.18
      NNO2K=NNO2                                                          CMPN2D.19
      NEK=NJ+NE                                                           CMPN2D.20
      NQTEFK=NQTEF-1                                                      CMPN2D.21
      NOPK=NJ+NOP                                                         CMPN2D.22
      NN2PK=NN2P                                                          CMPN2D.23
      NNOPK=NNOP                                                          CMPN2D.24
      DO K=1,KMAX                                                         CMPN2D.25
       NQTEFK=NQTEFK+1                                                    CMPN2D.26
       DO I=1,LEN1                                                        CMPN2D.27
C       ****                                                              CMPN2D.28
C       ****     S1 = EXPS(K+1/2),    S2 = PN2D(K+1/2)                    CMPN2D.29
C       ****                                                              CMPN2D.30
        S1(I,K)=EXPS(K)                                                   CMPN2D.31
        S2(I,K)=.5*(F(I,NQTEFK)+F(I,NQTEFK+1))*BRN2D                      CMPN2D.32
       ENDDO                                                              CMPN2D.33
      ENDDO                                                               CMPN2D.34
      DO I=1,LEN2                                                         CMPN2D.35
C      ****                                                               CMPN2D.36
C      ****     S1 = N*MBAR  (K+1/2)                                      CMPN2D.37
C      ****                                                               CMPN2D.38
       S1(I,1)=S1(I,1)*C(81)/(C(84)*F(I,NTK)*(F(I,NPS1K)/RMASS(1)+        CMPN2D.39
     1         F(I,NPS2K)/RMASS(2)+(1.-F(I,NPS1K)-F(I,NPS2K))/            CMPN2D.40
     2         RMASS(3)))                                                 CMPN2D.41
C      ****                                                               CMPN2D.42
C      ****     S2 = TOTAL N2D PRODUCTION                                 CMPN2D.43
C      ****                                                               CMPN2D.44
       S2(I,1)=S2(I,1)+RK3(I,1)*F(I,NN2PK)*S1(I,1)*F(I,NPS2K)/            CMPN2D.45
     1         RMASS(2)+(RA1(I,1)*F(I,NNOPK)*0.8+RA3(I,1)*                CMPN2D.46
     2         F(I,NN2PK)*0.9)*DSQRT(F(I,NEK)*F(I,NEK+1))                 CMPN2D.47
C      ****                                                               CMPN2D.48
C      ****     S3 = (TOTAL N2D LOSS)/N(N2D)                              CMPN2D.49
C      ****                                                               CMPN2D.50
       S3(I,1)=S1(I,1)*(BETA2(I,1)*F(I,NPS1K)/RMASS(1)+                   CMPN2D.51
     1         BETA4(I,1)*F(I,NPS2K)/RMASS(2)+BETA6(I,1)*                 CMPN2D.52
     2         F(I,NPNOK)/RMNO)+BETA7(I,1)+BETA5(I,1)*                    CMPN2D.53
     3         DSQRT(F(I,NEK)*F(I,NEK+1))+RK10(I,1)*F(I,NOPK)             CMPN2D.54
C      ****                                                               CMPN2D.55
C      ****     S1 = PSI(N2D)                                             CMPN2D.56
C      ****                                                               CMPN2D.57
       S1(I,1)=RMN2D*S2(I,1)/(S3(I,1)*S1(I,1))                            CMPN2D.58
      ENDDO                                                               CMPN2D.59
      NPN2DK=NPN2D+NJNP                                                   CMPN2D.60
      DO I=1,LEN2                                                         CMPN2D.61
C      ****                                                               CMPN2D.62
C      ****     F(NPN2DK) = PSI(N2D)                                      CMPN2D.63
C      ****                                                               CMPN2D.64
       F(I,NPN2DK)=S1(I,1)                                                CMPN2D.65
      ENDDO                                                               CMPN2D.66
      RETURN                                                              CMPN2D.67
      END                                                                 CMPN2D.68
C                                                                         CMPN2D.69
*DK CMPN4S                                                                CMPN4S.1
      SUBROUTINE CMPN4S                                                   CMPN4S.2
C     ****                                                                CMPN4S.3
C     ****     ADVANCES PSI(N4S) BY ONE TIME STEP                         CMPN4S.4
C     ****                                                                CMPN4S.5
      INCLUDE 'param.h'                                                   CMPN4S.6
      INCLUDE 'vscrw.h'                                                   CMPN4S.7
      INCLUDE 'const.h'                                                   CMPN4S.8
      INCLUDE 'index.h'                                                   CMPN4S.9
      INCLUDE 'buffe.h'                                                   CMPN4S.10
      INCLUDE 'rates.h'                                                   CMPN4S.11
      include 'phycs.h'
      COMMON/MASS/ RMN4S,RMN2D,RMNO,BRN2D,CEE                             CMPN4S.12
      DIMENSION PHIN4S(3)                                                 CMPN4S.13
      DATA PHIN4S/0.651,0.731,0.741/                                      CMPN4S.14
C     ****                                                                CMPN4S.15
C     ****     BOUNDARIES                                                 CMPN4S.16
C     ****                                                                CMPN4S.17
      NPNOK=NJ+NPNO                                                       CMPN4S.18
      NPN4SK=NJ+NPN4S                                                     CMPN4S.19
      NPN2DK=NPN2D+NJNP                                                   CMPN4S.20
      NTK=NJ+NT+KMAX                                                      CMPN4S.21
      NPS1K=NJ+NPS                                                        CMPN4S.22
      NPS2K=NPS1K+KMAXP1                                                  CMPN4S.23
      NMSK=NJ+NMS                                                         CMPN4S.24
      NNO2K=NNO2                                                          CMPN4S.25
      NEK=NJ+NE                                                           CMPN4S.26
      NQTEFK=NQTEF                                                        CMPN4S.27
      NO2PK=NJ+NO2P                                                       CMPN4S.28
      NOPK=NJ+NOP                                                         CMPN4S.29
      NN2PK=NN2P                                                          CMPN4S.30
      NNPK=NNP                                                            CMPN4S.31
      NNOPK=NNOP                                                          CMPN4S.32
      DO I=1,LEN1                                                         CMPN4S.33
C       ****                                                              CMPN4S.34
C       ****     T5 = N*MBAR                                              CMPN4S.35
C       ****                                                              CMPN4S.36
        T5(I)=C(81)*EXPS(1)*C(87)*F(I,NMSK)/(C(84)*F(I,NTK))              CMPN4S.37
C       ****                                                              CMPN4S.38
C       ****     VALUE AT BOTTOM GIVEN BY PHOTOCHEMICAL EQUILIBRIUM.      CMPN4S.39
C       ****                                                              CMPN4S.40
        T1(I)=0.                                                          CMPN4S.41
        T2(I)=1.                                                          CMPN4S.42
        T3(I)=-RMN4S/T5(I)*(F(I,NQTEFK)*(1.-BRN2D)/T5(I)+F(I,NPN2DK)/     CMPN4S.43
     1        RMN2D*(BETA4(I,1)*T5(I)*F(I,NPS2K)/RMASS(2)+BETA5(I,1)*     CMPN4S.44
     2        F(I,NEK)+BETA7(I,1))+BETA8(I,1)*F(I,NPNOK)/RMNO)/(          CMPN4S.45
     3        BETA1(I,1)*F(I,NPS1K)/RMASS(1)+BETA3(I,1)*F(I,NPNOK)/RMNO   CMPN4S.46
     4        +T5(I)*BETA17(I,1)*F(I,NPS2K)/RMASS(2)*(1.-F(I,NPS2K)-      CMPN4S.47
     5        F(I,NPS1K))/RMASS(3))                                       CMPN4S.48
C       ****                                                              CMPN4S.49
C       ****     ZERO DIFFUSIVE FLUX AT TOP                               CMPN4S.50
C       ****                                                              CMPN4S.51
        T4(I)=0.                                                          CMPN4S.52
      ENDDO                                                               CMPN4S.53
      NTK=NJ+NT                                                           CMPN4S.54
      DO K=1,KMAX                                                         CMPN4S.55
       DO I=1,LEN1                                                        CMPN4S.56
C       ****                                                              CMPN4S.57
C       ****     S3 = N*MBAR  (K+1/2)                                     CMPN4S.58
C       ****                                                              CMPN4S.59
        S3(I,K)=EXPS(K)*C(81)/(C(84)*F(I,NTK)*(F(I,NPS1K)/RMASS(1)+       CMPN4S.60
     1          F(I,NPS2K)/RMASS(2)+(1.-F(I,NPS1K)-F(I,NPS2K))/           CMPN4S.61
     2          RMASS(3)))                                                CMPN4S.62
C       ****                                                              CMPN4S.63
C       ****     S2 = NUMBER DENSITY PRODUCTION INDEPENDENT OF N(N4S)     CMPN4S.64
C       ****                                                              CMPN4S.65
        S2(I,K)=.5*(F(I,NQTEFK)+F(I,NQTEFK+1))*(1.-BRN2D)+S3(I,K)*        CMPN4S.66
     1          (F(I,NPN2DK)/RMN2D*(S3(I,K)*BETA4(I,K)*F(I,NPS2K)/        CMPN4S.67
     2          RMASS(2)+BETA5(I,K)*.5*(F(I,NEK)+F(I,NEK+1))+             CMPN4S.68
     3          BETA7(I,K))+.5*(BETA8(I,K)+BETA8(I+LEN1,K))*F(I,NPNOK)/   CMPN4S.69
     4          RMNO)+S3(I,K)*(RK2(I,K)*F(I,NOPK)*(1.-F(I,NPS1K)-         CMPN4S.70
     5          F(I,NPS2K))/RMASS(3)+RK6(I,K)*F(I,NNPK)*F(I,NPS1K)/       CMPN4S.71
     6          RMASS(1)+RK8(I,K)*F(I,NNPK)*F(I,NPS2K)/RMASS(2))+         CMPN4S.72
     7          DSQRT(F(I,NEK)*F(I,NEK+1))*(RA1(I,K)*F(I,NNOPK)*0.2+      CMPN4S.73
     8          RA3(I,K)*F(I,NN2PK)*1.1)                                  CMPN4S.74
C       ****                                                              CMPN4S.75
C       ****     S1 = (NUMBER DENSITY LOSS)/N(N4S)                        CMPN4S.76
C       ****                                                              CMPN4S.77
        S1(I,K)=-S3(I,K)*(BETA1(I,K)*F(I,NPS1K)/RMASS(1)+BETA3(I,K)*      CMPN4S.78
     1          F(I,NPNOK)/RMNO+S3(I,K)*BETA17(I,K)*F(I,NPS2K)/           CMPN4S.79
     2          RMASS(2)*(1.-F(I,NPS2K)-F(I,NPS1K))/RMASS(3))-            CMPN4S.80
     3          RK4(I,K)*F(I,NO2PK)                                       CMPN4S.81
       ENDDO                                                              CMPN4S.82
        NPNOK=NPNOK+1                                                     CMPN4S.83
        NPN4SK=NPN4SK+1                                                   CMPN4S.84
        NPN2DK=NPN2DK+1                                                   CMPN4S.85
        NTK=NTK+1                                                         CMPN4S.86
        NPS1K=NPS1K+1                                                     CMPN4S.87
        NPS2K=NPS2K+1                                                     CMPN4S.88
        NQTEFK=NQTEFK+1                                                   CMPN4S.89
        NMSK=NMSK+1                                                       CMPN4S.90
        NNO2K=NNO2K+1                                                     CMPN4S.91
        NEK=NEK+1                                                         CMPN4S.92
        NO2PK=NO2PK+1                                                     CMPN4S.93
        NOPK=NOPK+1                                                       CMPN4S.94
        NN2PK=NN2PK+1                                                     CMPN4S.95
        NNPK=NNPK+1                                                       CMPN4S.96
        NNOPK=NNOPK+1                                                     CMPN4S.97
      ENDDO                                                               CMPN4S.98
      IBND=0                                                              CMPN4S.99
      IBNDB=0                                                             CMPN4S.100
      ALFA=0.                                                             CMPN4S.101
      CALL MINOR(NPN4S,NN4SNM,RMN4S,PHIN4S,ALFA,IBND,IBNDB)               CMPN4S.102
c      njnopk=njnp+npn4s
c      if(j.eq.34)then
c      do k=1,kmax
c       do i=12,45
c        write(6,*)f(i,njnopk),i,k
c       enddo
c       njnopk=njnopk+1
c      enddo
c      endif
      RETURN                                                              CMPN4S.103
      END                                                                 CMPN4S.104
C                                                                         CMPN4S.105
*DK CMPNO                                                                  CMPNO.1
      SUBROUTINE CMPNO                                                     CMPNO.2
C     ****                                                                 CMPNO.3
C     ****     ADVANCES PSI(NO) BY ONE TIME STEP                           CMPNO.4
C     ****                                                                 CMPNO.5
      INCLUDE 'param.h'                                                    CMPNO.6
      INCLUDE 'vscrw.h'                                                    CMPNO.7
      INCLUDE 'const.h'                                                    CMPNO.8
      INCLUDE 'index.h'                                                    CMPNO.9
      INCLUDE 'buffe.h'                                                    CMPNO.10
      INCLUDE 'rates.h'                                                    CMPNO.11
      INCLUDE 'phycs.h'                                                    CMPNO.12
      REAL*8 NOB,NNOB                                                      CMPNO.13
      COMMON/RUNT/TTBOUND,NOB(ZJMX),AVTO,HOR(ZJMX)                         CMPNO.14
      COMMON/MASS/RMN4S,RMN2D,RMNO,BRN2D,CEE                               CMPNO.15
      DIMENSION PHINO(3)                                                   CMPNO.16
      DATA PHINO/0.814,0.866,0.926/                                        CMPNO.17
C     ****                                                                 CMPNO.18
C     ****     BOUNDARIES                                                  CMPNO.19
C     ****                                                                 CMPNO.20
C     ****     DIFFUSIVE EQUILIBRIUM AT UPPER BOUNDARY                     CMPNO.21
      DO I=1,LEN1                                                          CMPNO.22
       T4(I)=0.                                                            CMPNO.23
      ENDDO                                                                CMPNO.24
      IBND=0                                                               CMPNO.25
C     ****                                                                 CMPNO.26
C     ****     LOWER BOUNDARY: N(NO) = NOB(J)                              CMPNO.27
C     ****                                                                 CMPNO.28
      NNOB=NOB(J)                                                          CMPNO.29
      IBNDB=0                                                              CMPNO.30
      NMSK=NJ+NMS                                                          CMPNO.31
      NTK=NJ+NT+KMAX                                                       CMPNO.32
      DO I=1,LEN1                                                          CMPNO.33
       T1(I)=0.                                                            CMPNO.34
       T2(I)=1.                                                            CMPNO.35
       T3(I)=-NNOB*RMNO*C(84)*F(I,NTK)/(C(81)*C(87)*EXPS(1)*F(I,NMSK))     CMPNO.36
      ENDDO                                                                CMPNO.37
C     ****                                                                 CMPNO.38
C     ****     SOURCES                                                     CMPNO.39
C     ****                                                                 CMPNO.40
      NPNOK=NJ+NPNO                                                        CMPNO.41
      NPN4SK=NJ+NPN4S                                                      CMPNO.42
      NPN2DK=NPN2D+NJNP                                                    CMPNO.43
      NTK=NJ+NT                                                            CMPNO.44
      NPS1K=NJ+NPS                                                         CMPNO.45
      NPS2K=NPS1K+KMAXP1                                                   CMPNO.46
      NMSK=NJ+NMS                                                          CMPNO.47
      NNO2K=NNO2                                                           CMPNO.48
      NEK=NJ+NE                                                            CMPNO.49
      NO2PK=NJ+NO2P                                                        CMPNO.50
      DO K=1,KMAX                                                          CMPNO.51
       DO I=1,LEN1                                                         CMPNO.52
C       ****                                                               CMPNO.53
C       ****     S3 = EXPS                                                 CMPNO.54
C       ****                                                               CMPNO.55
        S3(I,K)=EXPS(K)                                                    CMPNO.56
       ENDDO                                                               CMPNO.57
      ENDDO  	                                                           CMPNO.58
      DO I=1,LEN2                                                          CMPNO.59
C      ****                                                                CMPNO.60
C      ****     S3 = N*MBAR   (K+1/2)                                      CMPNO.61
C      ****                                                                CMPNO.62
       S3(I,1)=C(81)*S3(I,1)/(C(84)*F(I,NTK)*(F(I,NPS1K)/RMASS(1)+         CMPNO.63
     1         F(I,NPS2K)/RMASS(2)+(1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3)))   CMPNO.64
C      ****                                                                CMPNO.65
C      ****     S2 = NUMBER DENSITY PRODUCTION                             CMPNO.66
C      ****                                                                CMPNO.67
       S2(I,1)=S3(I,1)**2*F(I,NPS1K)/RMASS(1)*(BETA1(I,1)*F(I,NPN4SK)/     CMPNO.68
     1         RMN4S+BETA2(I,1)*F(I,NPN2DK)/RMN2D)+                        CMPNO.69
     2         S3(I,1)**3*BETA17(I,1)*F(I,NPS2K)/RMASS(2)*(1.              CMPNO.70
     3         -F(I,NPS2K)-F(I,NPS1K))/RMASS(3)*F(I,NPN4SK)/RMN4S          CMPNO.71
C      ****                                                                CMPNO.72
C      ****     S1 = (NUMBER DENSITY LOSS)/N(NO)                           CMPNO.73
C      ****                                                                CMPNO.74
       S1(I,1)=-S3(I,1)*(BETA3(I,1)*F(I,NPN4SK)/RMN4S+BETA6(I,1)*          CMPNO.75
     1         F(I,NPN2DK)/RMN2D)-.5*(BETA8(I,1)+BETA8(I+LEN1,1)+          CMPNO.76
     2         BETA9(I,1)+BETA9(I+LEN1,1))-RK5(I,1)*F(I,NO2PK)             CMPNO.77
     3         -.5*(BETA9N(I,1)+BETA9N(I+LEN1,1))                          CMPNO.78
      ENDDO                                                                CMPNO.79
      ALFA=0.                                                              CMPNO.80
      CALL MINOR(NPNO,NPNONM,RMNO,PHINO,ALFA,IBND,IBNDB)                   CMPNO.81
c      njnopk=njnp+npno
c      if(j.eq.34)then
c      do k=1,kmax
c       do i=12,45
c        write(6,*)f(i,njnopk),i,k
c       enddo
c       njnopk=njnopk+1
c      enddo
c      endif
      RETURN                                                               CMPNO.82
      END                                                                  CMPNO.83
C                                                                          CMPNO.84
*DK                                                                       CMPO2O.1
      SUBROUTINE CMPO2O                                                   CMPO2O.2
C     ****                                                                CMPO2O.3
C     ****     CALCULATES FS ARRAY WHICH GIVES SOURCES AND SINK FOR COMP  CMPO2O.4
C     ****                                                                CMPO2O.5
      INCLUDE "param.h"                                                   CMPO2O.6
      INCLUDE "vscrw.h"                                                   CMPO2O.7
      INCLUDE "const.h"                                                   CMPO2O.8
      INCLUDE "index.h"                                                   CMPO2O.9
      INCLUDE "buffe.h"                                                   CMPO2O.10
      INCLUDE "rates.h"                                                   CMPO2O.11
      COMMON/FSARAY/FS(ZIMXP,ZKMXP,2,0:2)                                 CMPO2O.12
      COMMON/MASS/RMN4S,RMN2D,RMNO,BRN2D,CEE                              CMPO2O.13
C     ****                                                                CMPO2O.14
C     ****  CALCULATE FS ARRAY FOR COMP                                   CMPO2O.15
C     ****                                                                CMPO2O.16
      NRJK=NRJ-1                                                          CMPO2O.17
      NQO2PK=NQO2P-1                                                      CMPO2O.18
      NQOPK=NQOP-1                                                        CMPO2O.19
      DO K=1,KMAX                                                         CMPO2O.20
       NRJK=NRJK+1                                                        CMPO2O.21
       NQO2PK=NQO2PK+1                                                    CMPO2O.22
       NQOPK=NQOPK+1                                                      CMPO2O.23
       DO I=1,LEN1                                                        CMPO2O.24
C       ****                                                              CMPO2O.25
C       ****     S15 = EXPS       (K+1/2)                                 CMPO2O.26
C       ****                                                              CMPO2O.27
        S15(I,K)=EXPS(K)                                                  CMPO2O.28
        S12(I,K)=0.5*(F(I,NRJK)+F(I,NRJK+1))                              CMPO2O.29
        S11(I,K)=0.5*(F(I,NQO2PK)+F(I,NQO2PK+1))                          CMPO2O.30
        S9(I,K)=0.5*(F(I,NQOPK)+F(I,NQOPK+1))                             CMPO2O.31
       ENDDO                                                              CMPO2O.32
      ENDDO                                                               CMPO2O.33
C     ****                                                                CMPO2O.34
C     ****     SOURCES                                                    CMPO2O.35
C     ****                                                                CMPO2O.36
      NPS1K=NJ+NPS                                                        CMPO2O.37
      NPS2K=NPS1K+KMAXP1                                                  CMPO2O.38
      NMSK=NJ+NMS                                                         CMPO2O.39
      NOPK=NJ+NOP                                                         CMPO2O.40
      NPNOK=NJ+NPNO                                                       CMPO2O.41
      NPN4SK=NJ+NPN4S                                                     CMPO2O.42
      NPN2DK=NJ+NPN2D                                                     CMPO2O.43
      NO2PK=NJ+NO2P                                                       CMPO2O.44
      NN2PK=NN2P                                                          CMPO2O.45
      NNPK=NNP                                                            CMPO2O.46
      NNOPK=NNOP                                                          CMPO2O.47
      NEK=NJ+NE                                                           CMPO2O.48
      NTK=NJ+NT                                                           CMPO2O.49
      DO I=1,LEN2                                                         CMPO2O.50
C      ****                                                               CMPO2O.51
C      ****    S15 = N*MBAR  (K+1/2)                                      CMPO2O.52
C      ****                                                               CMPO2O.53
       S15(I,1)=S15(I,1)*C(81)/(C(84)*F(I,NTK)*(F(I,NPS1K)/RMASS(1)+      CMPO2O.54
     1          F(I,NPS2K)/RMASS(2)+(1.-F(I,NPS1K)-F(I,NPS2K))            CMPO2O.55
     2          /RMASS(3)))                                               CMPO2O.56
C      ****                                                               CMPO2O.57
C      ****     S1=BETA3*[N4S]*[NO]+BETA6*[N2D]*[NO]+BETA8*[NO]+          CMPO2O.58
C      ****        K4*[O2P]*[N4S]+K10*[OP]*[N2D]                          CMPO2O.59
C      ****     S1 IS THE PRODUCTION RATE OF[O] BY N,NO CHEMISTRY         CMPO2O.60
C      ****                                                               CMPO2O.61
       S1(I,1)=S15(I,1)*(S15(I,1)*(BETA3(I,1)*F(I,NPN4SK)/RMN4S+          CMPO2O.62
     1         BETA6(I,1)*F(I,NPN2DK)/RMN2D)*F(I,NPNOK)/RMNO+             CMPO2O.63
     2         0.5*(BETA8(I,1)+BETA8(I+LEN1,1))*F(I,NPNOK)/RMNO+          CMPO2O.64
     3         RK4(I,1)*F(I,NO2PK)*F(I,NPN4SK)/RMN4S+RK10(I,1)*           CMPO2O.65
     4         F(I,NOPK)*F(I,NPN2DK)/RMN2D)+(RA1(I,1)*F(I,NNOPK)+         CMPO2O.66
     5         2*RA2(I,1)*F(I,NO2PK))*dSQRT(F(I,NEK)*F(I,NEK+1))          CMPO2O.67
C      ****                                                               CMPO2O.68
C      ****     S2=BETA1*[N4S]+BETA2*[N2D]+K1*[OP]+K7*[NP]+O2             CMPO2O.69
C      ****        DISSOCIATION RATE BY PHOTOS                            CMPO2O.70
C      ****     S2*[O2] IS THE PRODUCTION RATE OF[O] BY O2 CHEMISTRY      CMPO2O.71
C      ****                                                               CMPO2O.72
       S2(I,1)=S15(I,1)*(BETA1(I,1)*F(I,NPN4SK)/RMN4S+BETA2(I,1)          CMPO2O.73
     1         *F(I,NPN2DK)/RMN2D)+RK1(I,1,1)*F(I,NOPK)+RK7(I,1)*         CMPO2O.74
     2         F(I,NNPK)+2.*S12(I,1)                                      CMPO2O.75
C      ****                                                               CMPO2O.76
C      ****     S3=GAMA IS THE LOSS OF O BY RECOMBINATION                 CMPO2O.77
C      ****                                                               CMPO2O.78
       S3(I,1)=2.*RKM12(I,1)*S15(I,1)/(.5*(F(I,NMSK)+F(I,NMSK+1)))        CMPO2O.79
C      ****                                                               CMPO2O.80
C      ****     S4=K3*[N2P]+K8*[NP] IS THE LOSS OF O BY ION CHEMISTRY     CMPO2O.81
C      ****                                                               CMPO2O.82
       S4(I,1)=RK3(I,1)*F(I,NN2PK)+RK8(I,1)*F(I,NNPK)                     CMPO2O.83
C      ****                                                               CMPO2O.84
C      ****     S6 IS THE PRODUCTION OF O2 BY RECOMBINATION               CMPO2O.85
C      ****     S10 IS THE PRODUCTION OF O2 BY ION CHEMISTRY              CMPO2O.86
C      ****                                                               CMPO2O.87
       S6(I,1)=RKM12(I,1)*S15(I,1)/(.5*(F(I,NMSK)+F(I,NMSK+1)))           CMPO2O.88
       S10(I,1)=RK5(I,1)*F(I,NPNOK)/RMNO*F(I,NO2PK)*S15(I,1)              CMPO2O.89
C      ****                                                               CMPO2O.90
C      ****     S13 IS THE TOTAL LOSS OF O2                               CMPO2O.91
C      ****                                                               CMPO2O.92
       S13(I,1)=S15(I,1)*(BETA1(I,1)*F(I,NPN4SK)/RMN4S+BETA2(I,1)*        CMPO2O.93
     1          F(I,NPN2DK)/RMN2D)+RK1(I,1,1)*F(I,NOPK)+(RK6(I,1)+        CMPO2O.94
     2          RK7(I,1))*F(I,NNPK)+RK9(I,1)*F(I,NN2PK)+S12(I,1)          CMPO2O.95
C      ****                                                               CMPO2O.96
C      ****   MATRIX COEFFICIENTS FOR O-O2-N2 SOLUTION                    CMPO2O.97
C      ****                                                               CMPO2O.98
       FS(I,1,1,1)=-S13(I,1)                                              CMPO2O.99
       FS(I,1,1,2)=S15(I,1)*S6(I,1)*F(I,NPS2K)/RMASS(2)*RMASS(1)          CMPO2O.100
     1             /RMASS(2)                                              CMPO2O.101
       FS(I,1,2,1)=S2(I,1)*RMASS(2)/RMASS(1)                              CMPO2O.102
       FS(I,1,2,2)=-S4(I,1)-S3(I,1)*F(I,NPS2K)/RMASS(2)*S15(I,1)          CMPO2O.103
       FS(I,1,1,0)=(S10(I,1)-S11(I,1))*RMASS(1)/S15(I,1)                  CMPO2O.104
       FS(I,1,2,0)=(S1(I,1)-S9(I,1))*RMASS(2)/S15(I,1)                    CMPO2O.105
      ENDDO                                                               CMPO2O.106
      RETURN                                                              CMPO2O.107
      END                                                                 CMPO2O.108
C                                                                         CMPO2O.109
*DK                                                                         COMP.1
      SUBROUTINE COMP                                                       COMP.2
C     ****                                                                  COMP.3
C     ****     ADVANCE PSI IN TIME                                          COMP.4
C     ****                                                                  COMP.5
      INCLUDE 'param.h'                                                     COMP.6
      INCLUDE 'start.h'                                                     COMP.7
      INCLUDE 'ccomp.h'                                                     COMP.8
      INCLUDE 'const.h'                                                     COMP.9
      INCLUDE 'index.h'                                                     COMP.10
      INCLUDE 'buffe.h'                                                     COMP.11
      INCLUDE 'phycs.h'                                                     COMP.12
      INCLUDE 'cpbnd.h'                                                     COMP.13
      COMMON/FSARAY/FS(ZIMXP,ZKMXP,2,0:2)                                   COMP.14
      DIMENSION PHI(2,3),DELTA(2,2)                                         COMP.15
      DATA PHI/0.,0.673,1.35,0.,1.11,0.769/,TAU/1.86D+3/,                   COMP.16
     1DELTA/1.,0.,0.,1./,T00/273./                                          COMP.17
      DATA SMALL/1.D-6/                                                     COMP.18
      DO I=1,LEN1                                                           COMP.19
       T1(I)=1.                                                             COMP.20
      ENDDO                                                                 COMP.21
      IF(ICOMP.EQ.1)CALL DFACT(T1,J,IMAXP4)                                 COMP.22
C     ****                                                                  COMP.23
C     ****     CALCULATE EMBAR                                              COMP.24
C     ****                                                                  COMP.25
      NPS1K=NJ+NPS                                                          COMP.26
      NPS2K=NPS1K+KMAXP1                                                    COMP.27
      DO I=1,LEN3                                                           COMP.28
       EMBAR(I,1)=1./(F(I,NPS1K)/RMASS(1)+F(I,NPS2K)/RMASS(2)+(1.-          COMP.29
     1            F(I,NPS1K)-F(I,NPS2K))/RMASS(3))                          COMP.30
      ENDDO                                                                 COMP.31
C     ****                                                                  COMP.32
C     ****     CALCULATE PS0 AND EMBAR0                                     COMP.33
C     ****                                                                  COMP.34
      DO I=1,LEN1                                                           COMP.35
       PS0(I,1)=B(I,1,1)*F(I,NPS1K)+B(I,1,2)*F(I,NPS2K)+FB(I,1)             COMP.36
       PS0(I,2)=B(I,2,1)*F(I,NPS1K)+B(I,2,2)*F(I,NPS2K)+FB(I,2)             COMP.37
       EMBAR0(I)=1./(PS0(I,1)/RMASS(1)+PS0(I,2)/RMASS(2)+(1.-PS0(I,1)       COMP.38
     A           -PS0(I,2))/RMASS(3))                                       COMP.39
C      ****                                                                 COMP.40
C      ****     WKS4=.5*(DMBAR/DZ)/MBAR                                     COMP.41
C      ****                                                                 COMP.42
       WKS4(I)=(EMBAR(I,1)-EMBAR0(I))/(C(3)*(EMBAR0(I)+EMBAR(I,1)))         COMP.43
      ENDDO                                                                 COMP.44
C     ****                                                                  COMP.45
C     ****     CALCULTE EP AND AK AT LEVEL 1/2, SET Z(0) TO ZERO            COMP.46
C     ****                                                                  COMP.47
      KM=1                                                                  COMP.47
      KP=2                                                                  COMP.49
C     ****                                                                  COMP.50
C     ****     EP(1/2)                                                      COMP.51
C     ****                                                                  COMP.52
      DO L=1,2                                                              COMP.53
       DO I=1,LEN1                                                          COMP.54
        EP(I,L,KP)=1.-(2./(EMBAR0(I)+EMBAR(I,1)))*(RMASS(L)+(EMBAR(I,1)-    COMP.55
     1             EMBAR0(I))/C(3))                                         COMP.56
        Z(I,1,L)=0.                                                         COMP.57
        ENDDO                                                               COMP.58
      ENDDO                                                                 COMP.59
      DO L=1,2                                                              COMP.60
       LL=3-L                                                               COMP.61
       NPSL=NJ+NPS+(L-1)*KMAXP1                                             COMP.62
       DO M=1,2                                                             COMP.63
        DO I=1,LEN1                                                         COMP.64
         AK(I,L,M,KP)=-DELTA(L,M)*(PHI(LL,3)+(PHI(LL,L)-PHI(LL,3))*.5*      COMP.65
     1                (PS0(I,L)+F(I,NPSL)))-(1.-DELTA(L,M))*(PHI(L,M)-      COMP.66
     2                PHI(L,3))*.5*(PS0(I,L)+F(I,NPSL))                     COMP.67
        ENDDO                                                               COMP.68
       ENDDO                                                                COMP.69
      ENDDO                                                                 COMP.70
C     ****                                                                  COMP.71
C     ****     WKS1=MBAR/M3*(T00/(T0+T))*0.25/(TAU*DET) AT LEVEL 1/2        COMP.72
C     ****                                                                  COMP.73
      NTK=NJ+NT+KMAX                                                        COMP.74
      DO I=1,LEN1                                                           COMP.75
      WKS1(I)=0.5*(EMBAR0(I)+EMBAR(I,1))/RMASS(3)*                          COMP.76
     1        (T00/F(I,NTK))**0.25/(TAU*(AK(I,1,1,KP)*AK(I,2,2,KP)-         COMP.77
     2        AK(I,1,2,KP)*AK(I,2,1,KP)))                                   COMP.78
      ENDDO                                                                 COMP.79
C     ****                                                                  COMP.80
C     ****     COMPLETE CALCULATION OF AK(1/2)                              COMP.81
C     ****                                                                  COMP.82
      DO L=1,2                                                              COMP.83
       DO M=1,2                                                             COMP.84
        DO I=1,LEN1                                                         COMP.85
         AK(I,L,M,KP)=AK(I,L,M,KP)*WKS1(I)                                  COMP.86
C        ****                                                               COMP.87
C        ****     SET GAMA(0) TO 0.                                         COMP.88
C        ****                                                               COMP.89
         GAMA(I,1,L,M)=0.                                                   COMP.90
        ENDDO                                                               COMP.91
       ENDDO                                                                COMP.92
      ENDDO                                                                 COMP.93
C     ****                                                                  COMP.94
C     ****     MAIN HEIGHT DO LOOP                                          COMP.95
C     ****                                                                  COMP.96
      NTKT=NJ+NT                                                            COMP.97
      DO K=1,KMAX                                                           COMP.98
C      ****                                                                 COMP.99
C      ****     CYCLE K LEVELS                                              COMP.101
C      ****                                                                 COMP.102
       KB=KM                                                                COMP.103
       KM=KP                                                                COMP.104
       KP=KB                                                                COMP.105
C      ****                                                                 COMP.106
C      **** EP(K+1/2)                                                       COMP.107
C      ****                                                                 COMP.108
       DO L=1,2                                                             COMP.109
        DO I=1,LEN1                                                         COMP.110
         EP(I,L,KP)=1.-(2./(EMBAR(I,K)+EMBAR(I,K+1)))*(RMASS(L)+            COMP.111
     1              (EMBAR(I,K+1)-EMBAR(I,K))/C(3))                         COMP.112
        ENDDO                                                               COMP.113
       ENDDO                                                                COMP.114
C      ****                                                                 COMP.115
C      ****     AK(K+1/2)                                                   COMP.116
C      ****                                                                 COMP.117
       DO L=1,2                                                             COMP.118
        LL=3-L                                                              COMP.119
        NPSL=NJ+NPS+(L-1)*KMAXP1+K                                          COMP.120
        DO M=1,2                                                            COMP.121
         DO I=1,LEN1                                                        COMP.122
        AK(I,L,M,KP)=-DELTA(L,M)*(PHI(LL,3)+(PHI(LL,L)-PHI(LL,3))*.5*       COMP.123
     1               (F(I,NPSL-1.)+F(I,NPSL)))-(1.-DELTA(L,M))*             COMP.124
     2               (PHI(L,M)-PHI(L,3))*.5*(F(I,NPSL-1)+F(I,NPSL))         COMP.125
         ENDDO                                                              COMP.126
        ENDDO                                                               COMP.127
       ENDDO                                                                COMP.128
C      ****                                                                 COMP.129
C      ****     WKS1=MBAR/M3*(T00/(T0+T))**0.25/(TAU*DET(ALFA))             COMP.130
C      ****                                                                 COMP.131
       NTK=NTKT+K                                                           COMP.132
       DO I=1,LEN1                                                          COMP.133
        WKS1(I)=0.5*(EMBAR(I,K)+EMBAR(I,K+1))/RMASS(3)*(T00/(.5*            COMP.134
     1          (F(I,NTK-1)+F(I,NTK))))**0.25/(TAU*(AK(I,1,1,KP)*           COMP.135
     2          AK(I,2,2,KP)-AK(I,1,2,KP)*AK(I,2,1,KP)))                    COMP.136
C       ****                                                                COMP.137
C       ****     EDDY DIFFUSION TERMS IN WKS3 AND WKS4                      COMP.138
C       ****                                                                COMP.139
        WKS3(I)=WKS4(I)                                                     COMP.140
        WKS4(I)=(EMBAR(I,K+1)-EMBAR(I,K))/(C(3)*(EMBAR(I,K)+                COMP.141
     1          EMBAR(I,K+1)))                                              COMP.142
       ENDDO                                                                COMP.143
C      ****                                                                 COMP.144
C      ****     FINISH CALCULATING AK(K+1/2) AND GENERATE PK, QK, RK        COMP.145
C      ****                                                                 COMP.146
       NWK=NJ+NW+K                                                          COMP.147
       NRJK=NRJ+K                                                           COMP.148
       DO L=1,2                                                             COMP.149
        DO M=1,2                                                            COMP.150
         DO I=1,LEN1                                                        COMP.151
          AK(I,L,M,KP)=AK(I,L,M,KP)*WKS1(I)                                 COMP.152
          PK(I,L,M)=(AK(I,L,M,KM)*(1./C(3)+EP(I,M,KM)/2.)-EXPS(K)*(C(87)    COMP.153
     1              *DIFK(K)*T1(I)*(1./C(3)-WKS3(I))+0.25*(F(I,NWK-1)+      COMP.154
     2              F(I,NWK)))*DELTA(L,M))/C(3)                             COMP.155
          RK(I,L,M)=(AK(I,L,M,KP)*(1./C(3)-EP(I,M,KP)/2.)-EXPS(K)*(C(86)    COMP.156
     1              *DIFK(K+1)*T1(I)*(1./C(3)+WKS4(I))-0.25*(F(I,NWK-1)+    COMP.157
     2              F(I,NWK)))*DELTA(L,M))/C(3)                             COMP.158
          QK(I,L,M)=-(AK(I,L,M,KM)*(1./C(3)-EP(I,M,KM)/2.)+AK(I,L,M,KP)*    COMP.159
     1              (1./C(3)+EP(I,M,KP)/2.))/C(3)+EXPS(K)*(((C(86)*         COMP.160
     2              DIFK(K+1)*(1./C(3)-WKS4(I))+C(87)*DIFK(K)*(1./C(3)+     COMP.161
     3              WKS3(I)))*T1(I)/C(3)+C(7))*DELTA(L,M)-FS(I,K,L,M))      COMP.162
         ENDDO                                                              COMP.163
        ENDDO                                                               COMP.164
       ENDDO                                                                COMP.165
C      ****                                                                 COMP.166
C      ****     CALCULATE HORIZONTAL ADVECTION IN FK ARRAY                  COMP.167
C      ****                                                                 COMP.168
       DO L=1,2                                                             COMP.169
        NPSL=NPS+(L-1)*KMAXP1+K-1                                           COMP.170
        CALL ADVECL(NPSL,FK(1,L),K)                                         COMP.171
       ENDDO                                                                COMP.172
C      ****                                                                 COMP.173
C      ****     ADD EXPLICIT SOURCE TERMS  TO FK                            COMP.174
C      ****                                                                 COMP.175
       DO I=1,LEN1                                                          COMP.176
        FK(I,1)=FK(I,1)-FS(I,K,1,0)                                         COMP.177
        FK(I,2)=FK(I,2)-FS(I,K,2,0)                                         COMP.178
       ENDDO                                                                COMP.179
C      ****                                                                 COMP.180
C      ****     SHAPIRO SMOOTHER                                            COMP.181
C      ****                                                                 COMP.182
       DO L=1,2                                                             COMP.183
        NPSK=NPSNM+(L-1)*KMAXP1+K-1                                         COMP.184
        NPJP2K=NJP2+NPSK                                                    COMP.185
        NPJP1K=NJP1+NPSK                                                    COMP.186
        NPSNMK=NJ+NPSK                                                      COMP.187
        NPJM1K=NJM1+NPSK                                                    COMP.188
        NPJM2K=NJM2+NPSK                                                    COMP.189
        DO I=1,LEN1                                                         COMP.190
         WKV1(I,L)=F(I,NPSNMK)-C(26)*(F(I,NPJP2K)+F(I,NPJM2K)-4.*           COMP.191
     1             (F(I,NPJP1K)+F(I,NPJM1K))+6.*F(I,NPSNMK))                COMP.192
        ENDDO                                                               COMP.193
       ENDDO                                                                COMP.194
       DO L=1,2                                                             COMP.194
        DO I=3,IMAXP2                                                       COMP.196
         WKV2(I,L)=WKV1(I,L)-C(26)*(WKV1(I+2,L)+WKV1(I-2,L)-4.*             COMP.197
     1             (WKV1(I+1,L)+WKV1(I-1,L))+6.*WKV1(I,L))                  COMP.198
        ENDDO                                                               COMP.199
       ENDDO                                                                COMP.200
C      ****                                                                 COMP.201
C      ****     COMPLETE CALCULATION OF RHS IN FK                           COMP.202
C      ****                                                                 COMP.203
       DO L=1,2                                                             COMP.204
        NPSDHK=NPSDH+(L-1)*KMAX+K-1                                         COMP.205
        DO I=3,IMAXP2                                                       COMP.206
         FK(I,L)=EXPS(K)*(WKV2(I,L)*C(7)-FK(I,L)+F(I,NPSDHK))               COMP.207
        ENDDO                                                               COMP.208
       ENDDO                                                                COMP.209
C      ****                                                                 COMP.210
C      ****     INSERT PERIODIC POINTS                                      COMP.211
C      ****                                                                 COMP.212
       DO L=1,2                                                             COMP.213
        DO I=1,2                                                            COMP.214
         FK(I,L)=FK(I+IMAX,L)                                               COMP.215
         FK(I+IMAXP2,L)=FK(I+2,L)                                           COMP.216
        ENDDO                                                               COMP.217
       ENDDO                                                                COMP.218
       IF(K.EQ.1) GO TO 13                                                  COMP.219
       IF(K.EQ.KMAX) GO TO 14                                               COMP.220
       GO TO 15                                                             COMP.221
   13  CONTINUE                                                             COMP.222
C      ****                                                                 COMP.223
C      ****     LOWER BNDRY                                                 COMP.224
C      ****                                                                 COMP.225
       DO L=1,2                                                             COMP.226
        DO M=1,2                                                            COMP.227
         DO KK=1,2                                                          COMP.228
          DO I=1,LEN1                                                       COMP.229
           QK(I,L,M)=QK(I,L,M)+PK(I,L,KK)*B(I,KK,M)                         COMP.230
          ENDDO                                                             COMP.231
         ENDDO                                                              COMP.232
        ENDDO                                                               COMP.233
       ENDDO                                                                COMP.234
       DO L=1,2                                                             COMP.235
        DO M=1,2                                                            COMP.236
         DO I=1,LEN1                                                        COMP.237
          FK(I,L)=FK(I,L)-PK(I,L,M)*FB(I,M)                                 COMP.238
          PK(I,L,M)=0.                                                      COMP.239
         ENDDO                                                              COMP.240
        ENDDO                                                               COMP.241
       ENDDO                                                                COMP.242
       GO TO 15                                                             COMP.243
   14  CONTINUE                                                             COMP.244
C      ****                                                                 COMP.245
C      ****     UPPER BNDRY                                                 COMP.246
C      ****                                                                 COMP.247
       DO L=1,2                                                             COMP.248
        DO M=1,2                                                            COMP.249
         DO I=1,LEN1                                                        COMP.250
        QK(I,L,M)=QK(I,L,M)+(1+.5*EP(I,M,KP)*C(3))/(1.-.5*EP(I,M,KP)*       COMP.251
     1              C(3))*RK(I,L,M)                                         COMP.252
          RK(I,L,M)=0.                                                      COMP.253
         ENDDO                                                              COMP.254
        ENDDO                                                               COMP.255
       ENDDO                                                                COMP.256
   15  CONTINUE                                                             COMP.257
C      ****                                                                 COMP.258
C      ****     QK=ALFAK=QK-PK*GAMA(K-1)                                    COMP.259
C      ****                                                                 COMP.260
       DO L=1,2                                                             COMP.261
        DO M=1,2                                                            COMP.262
         DO KK=1,2                                                          COMP.263
          DO I=1,LEN1                                                       COMP.264
           QK(I,L,M)=QK(I,L,M)-PK(I,L,KK)*GAMA(I,K,KK,M)                    COMP.265
          ENDDO                                                             COMP.266
         ENDDO                                                              COMP.267
        ENDDO                                                               COMP.268
       ENDDO                                                                COMP.277
C      ****                                                                 COMP.269
C      ****     WKS1=DET(ALFA)                                              COMP.270
C      ****                                                                 COMP.271
       DO I=1,LEN1                                                          COMP.272
        WKS1(I)=QK(I,1,1)*QK(I,2,2)-QK(I,1,2)*QK(I,2,1)                     COMP.273
       ENDDO                                                                COMP.274
C      ****                                                                 COMP.275
C      ****     WKM1=ALFAI                                                  COMP.276
C      ****                                                                 COMP.277
       DO L=1,2                                                             COMP.278
       LL=3-L                                                               COMP.279
        DO M=1,2                                                            COMP.280
         DO I=1,LEN1                                                        COMP.281
          WKM1(I,L,M)=(DELTA(L,M)*QK(I,LL,LL)-(1.-DELTA(L,M))*              COMP.282
     1                QK(I,L,M))/WKS1(I)                                    COMP.283
         ENDDO                                                              COMP.284
        ENDDO                                                               COMP.285
       ENDDO                                                                COMP.286
C      ****                                                                 COMP.287
C      ****     GAMA(K+1)=ALFAI*RK                                          COMP.288
C      ****     WKV1=FK-PK*Z(K)                                             COMP.289
C      ****                                                                 COMP.290
       DO L=1,2                                                             COMP.291
        DO I=1,LEN1                                                         COMP.292
         WKV1(I,L)=FK(I,L)                                                  COMP.293
        ENDDO                                                               COMP.294
        DO M=1,2                                                            COMP.295
         DO I=1,LEN1                                                        COMP.296
          GAMA(I,K+1,L,M)=0.                                                COMP.297
          WKV1(I,L)=WKV1(I,L)-PK(I,L,M)*Z(I,K,M)                            COMP.298
         ENDDO                                                              COMP.299
         DO KK=1,2                                                          COMP.300
          DO I=1,LEN1                                                       COMP.301
           GAMA(I,K+1,L,M)=GAMA(I,K+1,L,M)+WKM1(I,L,KK)*RK(I,KK,M)          COMP.302
          ENDDO                                                             COMP.303
         ENDDO                                                              COMP.304
        ENDDO                                                               COMP.305
       ENDDO                                                                COMP.306
C      ****                                                                 COMP.307
C      ****     Z(K+1)=WKM1*WKV1                                            COMP.308
C      ****                                                                 COMP.309
       DO L=1,2                                                             COMP.310
        DO I=1,LEN1                                                         COMP.311
         Z(I,K+1,L)=0.                                                      COMP.312
        ENDDO                                                               COMP.313
        DO M=1,2                                                            COMP.314
         DO I=1,LEN1                                                        COMP.315
          Z(I,K+1,L)=Z(I,K+1,L)+WKM1(I,L,M)*WKV1(I,M)                       COMP.316
         ENDDO                                                              COMP.317
        ENDDO                                                               COMP.318
       ENDDO                                                                COMP.319
      ENDDO                                                                 COMP.320
C     ****                                                                  COMP.321
C     ****     SET PSNP(KMAXP1) TO ZERO                                     COMP.322
C     ****                                                                  COMP.323
      DO L=1,2                                                              COMP.324
       NPSL=NJNP+NPS+(L-1)*KMAXP1+KMAX                                      COMP.325
       DO I=1,LEN1                                                          COMP.326
        F(I,NPSL)=0.                                                        COMP.327
       ENDDO                                                                COMP.328
      ENDDO                                                                 COMP.329
C     ****                                                                  COMP.330
C     ****     DOWNWARD SWEEP                                               COMP.331
C     ****                                                                  COMP.332
      DO KK=1,KMAX                                                          COMP.333
       K=KMAX+1-KK                                                          COMP.334
       DO L=1,2                                                             COMP.335
        NPSL=NJNP+NPS+(L-1)*KMAXP1+(K-1)                                    COMP.336
        DO I=1,LEN1                                                         COMP.337
         F(I,NPSL)=Z(I,K+1,L)                                               COMP.338
        ENDDO                                                               COMP.339
        DO M=1,2                                                            COMP.340
         NPSM=NJNP+NPS+(M-1)*KMAXP1+K                                       COMP.341
         DO I=1,LEN1                                                        COMP.342
          F(I,NPSL)=F(I,NPSL)-GAMA(I,K+1,L,M)*F(I,NPSM)                     COMP.343
         ENDDO                                                              COMP.344
        ENDDO                                                               COMP.345
       ENDDO                                                                COMP.346
      ENDDO                                                                 COMP.347
C     ****                                                                  COMP.348
C     ****     INSERT VALUE OF PS(KMAXP1) USING BNDRY CONDITION             COMP.349
C     ****                                                                  COMP.350
      DO L=1,2                                                              COMP.351
       NPSL=NJNP+NPS+(L-1)*KMAXP1+KMAX                                      COMP.352
       DO I=1,LEN1                                                          COMP.353
        F(I,NPSL)=(1.+.5*EP(I,L,KP)*C(3))/(1.-.5*EP(I,L,KP)*C(3))*          COMP.354
     1            F(I,NPSL-1)                                               COMP.355
       ENDDO                                                                COMP.356
      ENDDO                                                                 COMP.357
C     ****                                                                  COMP.358
C     ****     FILTER PSI                                                   COMP.359
C     ****                                                                  COMP.360
      IF(KUT(J).LT.IMAXH)THEN                                               COMP.361
       NPSK=NJNP+NPS                                                        COMP.362
       CALL FILTER(NPSK,2*KMAXP1,KUT(J))                                    COMP.363
      ENDIF                                                                 COMP.364
C     ****                                                                  COMP.365
C     ****     TIME SMOOTHING OF PSI                                        COMP.366
C     ****                                                                  COMP.367
      NPSNMK=NJ+NPSNM                                                       COMP.368
      NPSK=NJ+NPS                                                           COMP.369
      NPSNPK=NJNP+NPS                                                       COMP.370
      NPSMNK=NJNP+NPSNM                                                     COMP.371
      LEN=2*LEN3                                                            COMP.372
      DO I=1,LEN                                                            COMP.373
       F(I,NPSMNK)=C(30)*F(I,NPSK)+C(31)*(F(I,NPSNMK)+F(I,NPSNPK))          COMP.374
      ENDDO                                                                 COMP.375
C     ****                                                                  COMP.376
C     ****     INSERT PERIODIC POINTS                                       COMP.377
C     ****                                                                  COMP.378
      K1=NJNP+NPS                                                           COMP.379
      K2=K1+2*KMAXP1-1                                                      COMP.380
      DO N=1,2                                                              COMP.381
       DO I=1,2                                                             COMP.382
        DO K=K1,K2                                                          COMP.383
         F(I,K)=F(I+IMAX,K)                                                 COMP.384
         F(I+IMAXP2,K)=F(I+2,K)                                             COMP.385
        ENDDO                                                               COMP.386
       ENDDO                                                                COMP.387
       K1=NJNP+NPSNM                                                        COMP.388
       K2=K1+2*KMAXP1-1                                                     COMP.389
      ENDDO                                                                 COMP.390
C     ****                                                                  COMP.391
C     ****     INSURE NON-NEGATIVE PSI                                      COMP.392
C     ****                                                                  COMP.393
      NPS1K=NJNP+NPS                                                        COMP.394
      NPS2K=NJNP+NPS2                                                       COMP.395
      NPS1MK=NJNP+NPSNM                                                     COMP.396
      NPS2MK=NJNP+NPS2NM                                                    COMP.397
      DO I=1,LEN3                                                           COMP.398
       IF(F(I,NPS1K).LT.SMALL)F(I,NPS1K)=SMALL                              COMP.399
       IF(F(I,NPS2K).LT.SMALL)F(I,NPS2K)=SMALL                              COMP.400
       IF(F(I,NPS1MK).LT.SMALL)F(I,NPS1MK)=SMALL                            COMP.401
       IF(F(I,NPS2MK).LT.SMALL)F(I,NPS2MK)=SMALL                            COMP.402
      ENDDO                                                                 COMP.403
      TOTAL=1.-SMALL                                                        COMP.404
      DO I=1,LEN3                                                           COMP.405
       OXYGEN=F(I,NPS1K)+F(I,NPS2K)                                         COMP.406
       FRACTION=TOTAL/OXYGEN                                                COMP.407
       COMPARE=TOTAL-OXYGEN                                                 COMP.408
       IF(COMPARE.LE.0.)THEN                                                COMP.409
        F(I,NPS1K)=F(I,NPS1K)*FRACTION                                      COMP.410
        F(I,NPS2K)=F(I,NPS2K)*FRACTION                                      COMP.411
       ENDIF                                                                COMP.412
       OXYGEN=F(I,NPS1MK)+F(I,NPS2MK)                                       COMP.413
       COMPARE=TOTAL-OXYGEN                                                 COMP.414
       FRACTION=TOTAL/OXYGEN                                                COMP.415
       IF(COMPARE.LE.0.)THEN                                                COMP.416
        F(I,NPS1MK)=F(I,NPS1MK)*FRACTION                                    COMP.417
        F(I,NPS2MK)=F(I,NPS2MK)*FRACTION                                    COMP.418
       ENDIF                                                                COMP.419
      ENDDO                                                                 COMP.420
      RETURN                                                                COMP.421
      END                                                                   COMP.422
C                                                                           COMP.423
*DK CPKTKM                                                                CPKTKM.1
      SUBROUTINE CPKTKM                                                   CPKTKM.2
C     ****                                                                CPKTKM.3
C     ****     CALCULATES CP, KT AND KM                                   CPKTKM.4
C     ****                                                                CPKTKM.5
      INCLUDE 'param.h'                                                   CPKTKM.6
      INCLUDE 'const.h'                                                   CPKTKM.7
      INCLUDE 'index.h'                                                   CPKTKM.8
      INCLUDE 'buffe.h'                                                   CPKTKM.9
      include 'phycs.h'
      NPS1K=NJ+NPS                                                        CPKTKM.10
      NPS2K=NPS1K+KMAXP1                                                  CPKTKM.11
      NCPK=NCP                                                            CPKTKM.12
      NKTK=NKT                                                            CPKTKM.13
      NKMK=NKM                                                            CPKTKM.14
      DO I=1,LEN3                                                         CPKTKM.15
       PMBAR=1./(F(I,NPS1K)/RMASS(1)+F(I,NPS2K)/RMASS(2)+                 CPKTKM.16
     1       (1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3))                         CPKTKM.17
       PO2=PMBAR*F(I,NPS1K)/RMASS(1)                                      CPKTKM.18
       PO=PMBAR*F(I,NPS2K)/RMASS(2)                                       CPKTKM.19
       PN2=1.-PO2-PO                                                      CPKTKM.20
C      ****                                                               CPKTKM.21
C      ****     CP=R/2.*(PO2*7./32.+PN2*7./28.+PO*5./16.)                 CPKTKM.22
C      ****     KM=(PO2*4.03+PN2*3.42+PO*3.9)                             CPKTKM.23
C      ****     KT=(PO2+PN2)*56.+PO*75.9                                  CPKTKM.24
C      ****                                                               CPKTKM.25
       F(I,NCPK)=C(57)*.5*(PO2*7./32.+PN2*7./28.+PO*5./16.)               CPKTKM.26
       F(I,NKMK)=PO2*4.03+PN2*3.42+PO*3.9                                 CPKTKM.27
       F(I,NKTK)=(PO2+PN2)*56.+PO*75.9                                    CPKTKM.28
      ENDDO                                                               CPKTKM.29
      NTK=NJ+NT-1                                                         CPKTKM.30
      NKTK=NKTK-1                                                         CPKTKM.31
      NKMK=NKMK-1                                                         CPKTKM.32
      DO K=1,KMAX                                                         CPKTKM.33
       NKTK=NKTK+1                                                        CPKTKM.34
       NKMK=NKMK+1                                                        CPKTKM.35
       NTK=NTK+1                                                          CPKTKM.36
       DO I=1,LEN1                                                        CPKTKM.37
        F(I,NKMK)=F(I,NKMK)*F(I,NTK)**0.69*1.D-6                          CPKTKM.38
        F(I,NKTK)=F(I,NKTK)*F(I,NTK)**0.69                                CPKTKM.39
       ENDDO                                                              CPKTKM.40
      ENDDO                                                               CPKTKM.41
      NKTK=NKTK+1                                                         CPKTKM.34
      NKMK=NKMK+1                                                         CPKTKM.35
      DO I=1,LEN1
       F(I,NKMK)=F(I,NKMK)*F(I,NTK)**0.69*1.D-6
       F(I,NKTK)=F(I,NKTK)*F(I,NTK)**0.69
      ENDDO
      NKMK=NKMK+1                                                         CPKTKM.42
      NKTK=NKTK+1                                                         CPKTKM.43
      NCPK=NCPK+KMAXP1                                                    CPKTKM.44
      DO K=1,KMAX                                                         CPKTKM.45
       NKMK=NKMK-1                                                        CPKTKM.46
       NKTK=NKTK-1                                                        CPKTKM.47
       NCPK=NCPK-1                                                        CPKTKM.48
       DO I=1,LEN1                                                        CPKTKM.49
        F(I,NCPK)=.5*(F(I,NCPK)+F(I,NCPK-1))                              CPKTKM.50
        F(I,NKMK)=.5*(F(I,NKMK)+F(I,NKMK-1))                              CPKTKM.51
        F(I,NKTK)=.5*(F(I,NKTK)+F(I,NKTK-1))                              CPKTKM.52
       ENDDO                                                              CPKTKM.53
      ENDDO                                                               CPKTKM.54
      DO I=1,LEN1                                                         CPKTKM.55
       F(I,NCPK-1)=2.*F(I,NCPK-1)-F(I,NCPK)                               CPKTKM.56
       F(I,NKMK-1)=2.*F(I,NKMK-1)-F(I,NKMK)                               CPKTKM.57
       F(I,NKTK-1)=2.*F(I,NKTK-1)-F(I,NKTK)                               CPKTKM.58
      ENDDO                                                               CPKTKM.59
      RETURN                                                              CPKTKM.60
      END                                                                 CPKTKM.61
C                                                                         CPKTKM.62
*DK DFACT                                                                  DFACT.1
      SUBROUTINE DFACT(T,J,LEN)                                            DFACT.2
      INCLUDE 'param.h'                                                    DFACT.3
      INCLUDE 'const.h'                                                    DFACT.4
      DIMENSION T(1)                                                       DFACT.5
      REAL*8 NOB                                                           DFACT.6
      COMMON/RUNT/TTBOUND,NOB(ZJMX),AVTO,HOR(ZJMX)                         DFACT.7
C     ****                                                                 DFACT.8
C     ****     T3 = A = .5*(1.+SIN(PI*(ABS(RLATM)-PI/6.)/(PI/3.)))         DFACT.9
C     ****               FOR  ABS(RLATM).LT.PI/3.                          DFACT.10
C     ****          A = 1.    FOR  ABS(RLATM).GE.PI/3                      DFACT.11
C     ****                                                                 DFACT.12
      RLAT=(-87.5+(J-1)*5.)/57.295                                         DFACT.13
      IF(ABS(RLAT).GE.C(110)/4.5)THEN                                      DFACT.14
       FACK=1.                                                             DFACT.15
      ELSE                                                                 DFACT.16
      FACK=.5*(1+SIN(C(110)*(DABS(RLAT)-C(110)/9.)/(C(110)/4.5)))          DFACT.17
      ENDIF                                                                DFACT.18
C     ****                                                                 DFACT.19
C     ****     SET ARRAY GIVING HORIZONTAL VARIATION OF EDDY DIFFUSION     DFACT.20
C     ****     AND EDDY THERMAL CONDUCTIVITY.  IF VALUES ARE UNITY,        DFACT.21
C     ****     VALUE OF KE AT BOTTOM OF MODEL IS 5.D-6                     DFACT.22
C     ****                                                                 DFACT.23
      DO I=1,LEN                                                           DFACT.24
       T(I)=HOR(J)+FACK                                                    DFACT.25
      ENDDO                                                                DFACT.26
      RETURN                                                               DFACT.27
      END                                                                  DFACT.28
C                                                                          DFACT.29
*DK DIFFUS                                                                DIFFUS.1
      SUBROUTINE DIFFUS(TP,EN,H,ANS)                                      DIFFUS.2
C     ****                                                                DIFFUS.3
C     ****      EVALUATES   ANS = (D/(H*DZ)*TP+M*G/R)*EN                  DIFFUS.4
C     ****                                                                DIFFUS.5
      INCLUDE 'param.h'                                                   DIFFUS.6
      INCLUDE 'const.h'                                                   DIFFUS.7
      DIMENSION TP(ZIMXP,ZKMXP),EN(ZIMXP,ZKMXP),H(ZIMXP,ZKMXP),           DIFFUS.8
     A ANS(ZIMXP,ZKMXP)                                                   DIFFUS.9
      DATA RMOP/16./                                                      DIFFUS.10
      MGR=RMOP*C(54)/C(57)                                                DIFFUS.11
      DO I=1,LEN2-2*LEN1                                                  DIFFUS.12
       ANS(I,2)=1./(2.*H(I,2)*C(3))*(TP(I,3)*EN(I,3)-TP(I,1)              DIFFUS.13
     A          *EN(I,1))+MGR*EN(I,2)                                     DIFFUS.14
      ENDDO                                                               DIFFUS.15
C     ****                                                                DIFFUS.16
C     ****      UPPER AND LOWER BOUNDARIES                                DIFFUS.17
C     ****                                                                DIFFUS.18
      DO I=1,LEN1                                                         DIFFUS.19
       ANS(I,KMAX)=1./(H(I,KMAX)*C(3))*(TP(I,KMAX)*EN(I,KMAX)-            DIFFUS.20
     A             TP(I,KMAXM1)*EN(I,KMAXM1))+MGR*EN(I,KMAX)              DIFFUS.21
       ANS(I,1)=1./(H(I,1)*C(3))*(TP(I,2)*EN(I,2)-                        DIFFUS.22
     A          TP(I,1)*EN(I,1))+MGR*EN(I,1)                              DIFFUS.23
      ENDDO                                                               DIFFUS.24
      RETURN                                                              DIFFUS.25
      END                                                                 DIFFUS.26
C                                                                         DIFFUS.27
*DK DIVB                                                                    DIVB.1
      SUBROUTINE DIVB(DVB,J)                                                DIVB.2
C     ****                                                                  DIVB.3
C     ****      EVALUATES THE DIVERGENCE OF B, THE UNIT MAGNETIC FIELD      DIVB.4
C     ****      VECTOR                                                      DIVB.5
C     ****                                                                  DIVB.6
      INCLUDE 'param.h'                                                     DIVB.7
      INCLUDE 'const.h'                                                     DIVB.8
      COMMON/MAGFLD/BXM(ZIMXP,2),BX(ZIMXP,ZJMX),BXP(ZIMXP,4),               DIVB.9
     1      BY(ZIMXP,ZJMX),BYP(ZIMXP,4),BZ(ZIMXP,ZJMX),BZP(ZIMXP,4),        DIVB.10
     2      BMOD(ZIMXP,ZJMX),BMODP(ZIMXP,2)                                 DIVB.11
      DIMENSION DVB(ZIMXP)                                                  DIVB.12
      DO I=3,IMAXP2                                                         DIVB.13
       DVB(I)=(((BX(I+1,J)-BX(I-1,J))/(2.*C(1))+(CS(J+1)*BY(I,J+1)-         DIVB.14
     A        CS(J-1)*BY(I,J-1))/(2.*C(2)))/CS(J)+2.*BZ(I,J))/C(51)         DIVB.15
      ENDDO                                                                 DIVB.16
C     ****                                                                  DIVB.17
C     ****      PERIODIC POINTS                                             DIVB.18
C     ****                                                                  DIVB.19
      DO I=1,2                                                              DIVB.20
       DVB(I)=DVB(I+IMAX)                                                   DIVB.21
       DVB(I+IMAXP2)=DVB(I+2)                                               DIVB.22
      ENDDO                                                                 DIVB.23
      RETURN                                                                DIVB.24
      END                                                                   DIVB.25
C                                                                           DIVB.26
*DK DIVRG                                                                  DIVRG.1
      SUBROUTINE DIVRG(S)     !                                            DIVRG.2
      INCLUDE 'param.h'                                                    DIVRG.3
      INCLUDE 'buffe.h'                                                    DIVRG.4
      INCLUDE 'const.h'                                                    DIVRG.5
      INCLUDE 'index.h'                                                    DIVRG.6
      INCLUDE 'phycs.h'                                                    DIVRG.7
      DIMENSION S(ZIMXP,ZKMXP),D2U(ZIMXP,ZKMXP),D4U(ZIMXP,ZKMXP),          DIVRG.8
     1          DVC(ZIMXP,ZKMXP)                                           DIVRG.9
C     ****                                                                 DIVRG.10
C     ****                   COMPUTE D(U)/DLAMDA                           DIVRG.11
C     ****                                                                 DIVRG.12
      NUK=NJ+NU-1                                                          DIVRG.13
      NVCPK=NJP1+NVC-1                                                     DIVRG.14
      NVCMK=NJM1+NVC-1                                                     DIVRG.15
C     ****                                                                 DIVRG.16
C     ****                   D2U=(U(I+1)-U(I-1))*C(10)                     DIVRG.17
C     ****                   D4U=(U(I+2)-U(I-2))*C(11)                     DIVRG.18
C     ****                   DVC=(VCJP1(I)-VCJM1(I))*C(12)                 DIVRG.19
C     ****                   S=D2U-D4U+DVC                                 DIVRG.20
C     ****                                                                 DIVRG.21
      DO K=1,KMAX                                                          DIVRG.22
       NUK=NUK+1                                                           DIVRG.23
       NVCPK=NVCPK+1                                                       DIVRG.24
       NVCMK=NVCMK+1                                                       DIVRG.25
       DO I=3,IMAXP2                                                       DIVRG.26
        D2U(I,K)=(F(I+1,NUK)-F(I-1,NUK))*C(10)                             DIVRG.27
        D4U(I,K)=(F(I+2,NUK)-F(I-2,NUK))*C(11)                             DIVRG.28
        DVC(I,K)=(F(I,NVCPK)-F(I,NVCMK))*C(12)                             DIVRG.29
        S(I,K)=D2U(I,K)-D4U(I,K)+DVC(I,K)                                  DIVRG.30
       ENDDO                                                               DIVRG.31
      ENDDO                                                                DIVRG.32
C     ****                                                                 DIVRG.33
C     ****                   DVC=(VCJP2(I)-VCJM2(I))*C(13)                 DIVRG.34
C     ****                                                                 DIVRG.35
      NVCPK=NJP2+NVC-1                                                     DIVRG.36
      NVCMK=NJM2+NVC-1                                                     DIVRG.37
      DO K=1,KMAX                                                          DIVRG.38
       NVCPK=NVCPK+1                                                       DIVRG.39
       NVCMK=NVCMK+1                                                       DIVRG.40
       DO I=3,IMAXP2                                                       DIVRG.41
        DVC(I,K)=(F(I,NVCPK)-F(I,NVCMK))*C(13)                             DIVRG.42
       ENDDO                                                               DIVRG.43
      ENDDO                                                                DIVRG.44
C     ****                                                                 DIVRG.45
C     ****                   S=(S-DVC)*RACS                                DIVRG.46
C     ****                                                                 DIVRG.47
      DO K=1,KMAX                                                          DIVRG.48
       DO I=1,2                                                            DIVRG.49
        S(I,K)=S(I+IMAX,K)                                                 DIVRG.50
        S(I+IMAXP2,K)=S(I+2,K)                                             DIVRG.51
        DVC(I,K)=DVC(I+IMAX,K)                                             DIVRG.52
        DVC(I+IMAXP2,K)=DVC(I+2,K)                                         DIVRG.53
       ENDDO                                                               DIVRG.54
      ENDDO                                                                DIVRG.55
      DO K=1,KMAX                                                          DIVRG.56
       DO I=1,LEN1                                                         DIVRG.57
        S(I,K)=(S(I,K)-DVC(I,K))*RACS                                      DIVRG.58
       ENDDO                                                               DIVRG.59
      ENDDO                                                                DIVRG.60
      RETURN                                                               DIVRG.61
      END                                                                  DIVRG.62
C                                                                          DIVRG.63
*DK DLDP                                                                    DLDP.1
      SUBROUTINE DLDP(NX,XL,XP,LEN)                                         DLDP.2
      INCLUDE 'param.h'                                                     DLDP.3
      INCLUDE 'buffe.h'                                                     DLDP.4
      INCLUDE 'const.h'                                                     DLDP.5
      DIMENSION XL(1),XP(1)                                                 DLDP.6
      LENP2=LEN+2                                                           DLDP.7
C     ****                                                                  DLDP.8
C     ****                   COMPUTE LONGITUDINAL DERIVATIVE                DLDP.9
C     ****                                                                  DLDP.10
      NXK=NJ+NX                                                             DLDP.11
      DO I=3,LENP2                                                          DLDP.12
       XL(I)=C(10)*(F(I+1,NXK)-F(I-1,NXK))-C(11)*(F(I+2,NXK)-F(I-2,NXK))    DLDP.13
      ENDDO                                                                 DLDP.14
C     ****                                                                  DLDP.15
C     ****                   COMPUTE LATITUDINAL DERIVATIVE                 DLDP.16
C     ****                                                                  DLDP.17
      NXJP2K=NJP2+NX                                                        DLDP.18
      NXJP1K=NJP1+NX                                                        DLDP.19
      NXJM1K=NJM1+NX                                                        DLDP.20
      NXJM2K=NJM2+NX                                                        DLDP.21
      DO I=3,LENP2                                                          DLDP.22
       XP(I)=C(12)*(F(I,NXJP1K)-F(I,NXJM1K))-                               DLDP.23
     1       C(13)*(F(I,NXJP2K)-F(I,NXJM2K))                                DLDP.24
      ENDDO                                                                 DLDP.25
      RETURN                                                                DLDP.26
      END                                                                   DLDP.27
C                                                                           DLDP.28
*DK DTUV                                                                      DT.1
      SUBROUTINE DT                                                           DT.2
C     ****                                                                    DT.3
C     ****     ADVANCES T,U AND V IN TIME                                     DT.4
C     ****                                                                    DT.5
      INCLUDE 'param.h'                                                       DT.6
      INCLUDE 'vscrw.h'                                                       DT.7
      INCLUDE 'const.h'                                                       DT.8
      INCLUDE 'index.h'                                                       DT.9
      INCLUDE 'buffe.h'                                                       DT.10
      INCLUDE 'phycs.h'                                                       DT.11
      INCLUDE 'start.h'                                                       DT.12
      INCLUDE 'rates.h'                                                       DT.13
      REAL*8 NOB                                                          NEWTON.13
      COMMON/RUNT/TTBOUND,NOB(ZJMX),AVTO,HOR(ZJMX)                            DT.8
      common/maxte/temax
      COMPLEX*16 EXPT                                                         DT.14
C     ****                                                                    DT.15
C     ****     /EDDDY/ contains arrays of DIFKT and DIFKK                     DT.16
C     ****     DIFKT = eddy thermal conductivity used in subroutine DT.       DT.17
C     ****     DIFKK = eddy diffusion used in subroutines COMP, MINOR         DT.18
C     ****             and MINOR2                                             DT.19
C     ****                                                                    DT.20
C     ****     First calculate T(n+1) using a finite difference               DT.21
C     ****      approximation to the thermodynamic equation.  The leap-       DT.22
C     ****      frog scheme is used with vertical diffusion treated           DT.23
C     ****      implicitly to second order accuracy.  This leads to a         DT.24
C     ****      tridiagonal scheme requiring boundary conditions at the       DT.25
C     ****      top and bottom of the domain as implied by the                DT.26
C     ****      differential equation itself.  The horizontal advection       DT.27
C     ****      is treated to 4th order accuracy.  At level k the             DT.28
C     ****      differential equation becomes;                                DT.29
C     ****                                                                    DT.30
C     ****       P(k,n)*T(k-1,n+1) + Q(k,n)*T(k,n+1) + R(k,n)*T(k+1,n+1)      DT.31
C     ****                                                                    DT.32
C     ****         = S(k,n)                                       (1)         DT.33
C     ****                                                                    DT.34
C     ****        where                                                       DT.35
C     ****         k = vertical grid index, range k = 3/2, K-1/2, 1           DT.36
C     ****         n = time-step index                                        DT.37
C     ****                                                                    DT.38
C     ****         Variables are assumed to have indices (k,n) unless         DT.39
C     ****         otherwise stated.                                          DT.40
C     ****                                                    _               DT.41
C     ****         P(k,n) = -(G(k-1/2,n) - F(k-1/2,n))         |              DT.42
C     ****                                                     |              DT.43
C     ****         Q(k,n) = G(k-1/2,n)+G(k+1/2,n)+F(k-1/2,n)-  |              DT.44
C     ****                                                     |              DT.45
C     ****                  F(k+1/2,n)+cp*exp(-s)*             |              DT.46
C     ****                                                     |              DT.47
C     ****                  (1/(2*Dt)+ai/cp+w*R/(cp*M))        |  (2)         DT.48
C     ****                                                     |              DT.49
C     ****         R(k,n) = -(G(k+1/2,n) + F(k+1/2,n))         |              DT.50
C     ****                                                     |              DT.51
C     ****         S(k,n) = cp*exp(-s)*(T(k,n-1)/(2*Dt)-       |              DT.52
C     ****                                                     |              DT.53
C     ****             V.del(T(k,n))+(Q+QDH+GWT+QJ+QM)/cp-     |              DT.54
C     ****                                      ae*exp(-s)     |              DT.55
C     ****                                                    _|              DT.56
C     ****            G = g*KT/(p0*H*Ds**2)                                   DT.57
C     ****            F = g*eps/(p0*2*H*Ds)                                   DT.58
C     ****            g = acceleration due to gravity   (cm/sec**2)           DT.59
C     ****            KT = kT + H**2*rho*cp*kE                                DT.60
C     ****            eps = kE*H**3*rho*g/T                                   DT.61
C     ****            kT = vertical molecular diffusion of heat               DT.62
C     ****                                        (ergs/cm/deg/sec)           DT.63
C     ****            kE = Eddy thermal diffusion           (1/sec)           DT.64
C     ****            p = pressure                    (dynes/cm**2)           DT.65
C     ****            p0 = reference pressure         (dynes/cm**2)           DT.66
C     ****            H = scale height = R*T/(M*g)             (cm)           DT.67
C     ****            s = vertical pressure coordinate = ln(p0/p)             DT.68
C     ****            Ds = grid interval of vertical coordinate, s.           DT.69
C     ****            cp = specific heat at constant pressure                 DT.70
C     ****                                            (ergs/deg/gm)           DT.71
C     ****            M = mean molecular mass                                 DT.72
C     ****            t = time                                (sec)           DT.73
C     ****            Dt = time step                          (sec)           DT.74
C     ****            ai = coefficient of implicit portion of radiative       DT.75
C     ****                 cooling                          (1/sec)           DT.76
C     ****            ae = explicit portion of radiative cooling              DT.77
C     ****                                            (ergs/sec/gm)           DT.78
C     ****            w = ds/dt (1/sec)                                       DT.79
C     ****            V.del(T) = total 3d advection of T  (deg/sec)           DT.80
C     ****            Q = total heating rate from all sources                 DT.81
C     ****                                            (ergs/sec/gm)           DT.82
C     ****            QDH = heating due to 4th order horizontal               DT.83
C     ****                  diffusion                                         DT.84
C     ****            GWT = heating due to gravity graves                     DT.85
C     ****            rho = density                      (gm/cm**3)           DT.86
C     ****            R = gas constant per mole          (ergs/deg)           DT.87
C     ****                                                                    DT.88
C     ****      Boundary conditions:                                          DT.89
C     ****                                                                    DT.90
C     ****       The lower boundary of the model is at k = 1                  DT.91
C     ****        T is given at this level as the sum of a global mean        DT.92
C     ****        value plus perturbations due to semidiurnal, diurnal        DT.93
C     ****        and annual tides.  At level k = 3/2, (1) becomes:           DT.94
C     ****                                                                    DT.95
C     ****         (Q(3/2,n)-P(3/2,n))*T(3/2,n+1) + R(3/2,n)*T(5/2,n+1)       DT.96
C     ****                                                                    DT.97
C     ****           = S(3/2,n) - 2*P(3/2,n)*TB                     (3)       DT.98
C     ****                                                                    DT.99
C     ****       The upper boundary is at k = K                               DT.100
C     ****        At this level:                                              DT.101
C     ****                                                                    DT.102
C     ****         (KT*d/ds + eps)T = 0                                       DT.103
C     ****                                                                    DT.104
C     ****        or in finite difference form:                               DT.105
C     ****                                                                    DT.106
C     ****         (G(K,n)-F(K,n))*T(K-1/2,n+1) -                             DT.107
C     ****                                                                    DT.108
C     ****                         (G(K,n)+F(K,n))*T(K+1/2,n+1) = 0           DT.109
C     ****                                                                    DT.110
C     ****        This implies that at level k = K-1/2, (1) becomes:          DT.111
C     ****                                                                    DT.112
C     ****         P(K-1/2,n)*T(K-3/2,n+1) + QT(K-1/2)*T(K-1/2,n+1)           DT.113
C     ****                                                                    DT.114
C     ****                                       = S(K-1/2,n)       (4)       DT.115
C     ****                                                                    DT.116
C     ****        where                                                       DT.117
C     ****                                                                    DT.118
C     ****         QT(K-1/2,n) = G(K-1,n) + F(K-1,n)) + cp*exp(-s)*           DT.119
C     ****                                                                    DT.120
C     ****                             (1/(2*Dt)+ai/cp+w*R/(cp*M))            DT.121
C     ****                                                                    DT.122
C     ****         P(K-1/2,n) and S(K-1/2,n) are unchanged                    DT.123
C     ****                                                                    DT.124
C     ****      Equations (1) through (4) provide a tridiagonal system        DT.125
C     ****       of order (K-1), which is readily solved.                     DT.126
C     ****                                                                    DT.127
C     ****                                                                    DT.128
C     ****     Evaluate tidal lower boundary condition for T.                 DT.129
C     ****      This includes semidiurnal, diurnal and annual tides.          DT.130
C     ****                                                                    DT.131
C     ****       T1 = temperature at lower boundary                           DT.132
C     ****                                                                    DT.133
C     ****       EXPT = exp(i*nusd*t)  (time varying factor in                DT.134
C     ****        semidiurnal tide)                                           DT.135
C     ****        where i = sqrt(-1)                                          DT.136
C     ****              nusd = semidiurnal frequency (radians/sec)            DT.137
C     ****              t = current model time (sec)                          DT.138
C     ****                                                                    DT.139
C     ****         Lower Boundary Conditions                                  DT.140
C     ****                                                                    DT.141
      EXPT=CDEXP(CI*C(23)*C(4)*DBLE(ITER))                                    DT.142
      DO I=1,LEN1                                                             DT.143
       T1(I)=DREAL(TB(J)*BND(I)*EXPT)+TTBOUND                                 DT.144
      ENDDO                                                                   DT.145
      EXPT=CDEXP(CI*.5*C(23)*C(4)*DBLE(ITER))                                 DT.146
      DO I=1,LEN1                                                             DT.147
       T1(I)=T1(I)+DREAL(TB2(J)*BND2(I)*EXPT)                                 DT.147
      ENDDO                                                                   DT.149
      EXPT=(1.,0.)                                                            DT.150
      DO I=1,LEN1                                                             DT.151
       T1(I)=T1(I)+DREAL(TBA(J)*BNDA(I)*EXPT)                                 DT.152
      ENDDO                                                                   DT.153
c     ****                                                                    DT.154
c     ****     S1=ADVEC(T)                                                    DT.155
c     ****                                                                    DT.156
      CALL ADVEC(NT,S1)                                                       DT.157
c     ****                                                                    DT.158
c     ****     S1=ADVEC(T)+ADVECV(T)                                          DT.159
c     ****                                                                    DT.160
      CALL ADVECV(NT,S1,T1)                                                   DT.161
C     ****                                                                    DT.162
C     ****     Shapiro smoother operating on T(n-1) in 2 stages               DT.163
C     ****                                                                    DT.164
C     ****      1) S2 = Result after meridional smoothing of T(n-1)           DT.165
C     ****                                                    (k+1/2)         DT.166
C     ****                                                                    DT.167
      NTJP2K=NJP2+NTNM                                                        DT.168
      NTJP1K=NJP1+NTNM                                                        DT.169
      NTNMK=NJ+NTNM                                                           DT.170
      NTJM1K=NJM1+NTNM                                                        DT.171
      NTJM2K=NJM2+NTNM                                                        DT.172
      DO I=1,LEN2                                                             DT.173
       S2(I,1)=F(I,NTNMK)-C(26)*(F(I,NTJP2K)+F(I,NTJM2K)-4.*                  DT.174
     1       (F(I,NTJP1K)+F(I,NTJM1K))+6.*F(I,NTNMK))                         DT.175
      ENDDO                                                                   DT.176
C     ****                                                                    DT.177
C     ****      2) S3 = Result after zonal smoothing of S2  (k+1/2)           DT.178
C     ****             = smoothed T(n-1)                                      DT.179
C     ****                                                                    DT.180
      DO I=3,LEN2-2                                                           DT.181
       S3(I,1)=S2(I,1)-C(26)*(S2(I+2,1)+S2(I-2,1)-4.*(S2(I+1,1)+              DT.182
     1         S2(I-1,1))+6.*S2(I,1))                                         DT.183
      ENDDO                                                                   DT.184
C     ****                                                                    DT.185
C     ****     S1 = cp*exp(-s)*(V.del(T(n))-1/(2*DT))*T(n-1) (k+1/2)          DT.186
C     ****                                                                    DT.187
C     ****     S8 = MBAR = 1./(psi(o2)/m(o2) + psi(o)/m(o) +                  DT.188
C     ****                 psi(n2)/m(n2))                    (K+1/2)          DT.189
C     ****                                                                    DT.190
      NCPK=NCP-1                                                              DT.191
      NPS1K=NJ+NPS                                                            DT.192
      NPS2K=NJ+NPS2                                                           DT.193
      DO K=1,KMAX                                                             DT.194
       NCPK=NCPK+1                                                            DT.195
       NPS1K=NPS1K+1                                                          DT.196
       NPS2K=NPS2K+1                                                          DT.197
       DO I=1,LEN1                                                            DT.198
        S1(I,K)=.5*(F(I,NCPK)+F(I,NCPK+1))*EXPS(K)*(S1(I,K)-C(7)*             DT.199
     1          S3(I,K))                                                      DT.200
        S8(I,K)=1./(F(I,NPS1K)/RMASS(1) + F(I,NPS2K)/RMASS(2) +               DT.201
     1          (1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3))                          DT.202
       ENDDO                                                                  DT.203
      ENDDO                                                                   DT.204
C     ****                                                                    DT.205
C     ****     Calculate total heat sources in S5         (k+1/2)             DT.206
C     ****                                                                    DT.207
      NQK=NQ                                                                  DT.208
      NQDHK=NQDH                                                              DT.209
      DO I=1,LEN2                                                             DT.210
C      ****                                                                   DT.211
C      ****      First solar heating:                                         DT.212
C      ****                                                                   DT.213
C      ****       S5(k) = .5*(Q(k)+Q(k+1))               (k+1/2)              DT.214
C      ****                                                                   DT.215
       S5(I,1)=.5*(F(I,NQK)+F(I,NQK+1))                                       DT.216
C      ****                                                                   DT.217
C      ****      Add heating from 4th order horizontal diffusion              DT.218
C      ****                                              (k+1/2)              DT.219
       S5(I,1)=S5(I,1)+F(I,NQDHK)                                             DT.220
      ENDDO                                                                   DT.222
      NTK=NJ+NT-1                                                             DT.223
      NPS2K=NJ+NPS2-1                                                         DT.224
      DO K=1,KMAX                                                             DT.225
       NTK=NTK+1                                                              DT.226
       NPS2K=NPS2K+1                                                          DT.227
       DO I=1,LEN1                                                            DT.228
C       ****                                              (k+1/2)             DT.229
C       ****      Add heating due to atomic oxygen recombination              DT.230
C       ****                                              (k+1/2)             DT.231
C       ****       Reaction is:                                               DT.232
C       ****        O + O + M -> O2 + M                                       DT.233
C       ****        where M is N2, O2 or O                                    DT.234
C       ****                                                                  DT.235
C       ****       Recombination rate = rk*n(O)**2*n  (events/sec/cc)         DT.236
C       ****                                                                  DT.237
C       ****        where rk = reaction rate                                  DT.238
C       ****              n(O) = number density of O (1/cc)                   DT.239
C       ****              n = total number density (1/cc)                     DT.240
C       ****                                                                  DT.241
C       ****       Heating rate = h(O)*rk*n(O)**2*n/rho (ergs/sec/gm)         DT.242
C       ****                                                                  DT.243
C       ****        where h(O) = heat generated per event (ergs)              DT.244
C       ****              rho = density  (gm/cc)                              DT.245
C       ****       In terms of mass mixing ratios,                            DT.246
C       ****                                                                  DT.247
C       ****        heating rate = h(O)*rk*((n*M)*psi(O)/M(O))**2*N0/M        DT.248
C       ****                                                                  DT.249
C       ****        where M = mean molecular weight                           DT.250
C       ****              M(O) = molecular weight of O                        DT.251
C       ****              psi(O) = mass mixing of O                           DT.252
C       ****              N0 = Avogadro's number                              DT.253
C       ****                                                                  DT.254
        S5(I,K)=S5(I,K)+C(45)*RKM12(I,K)*(C(81)*EXPS(K)*S8(I,K)/              DT.255
     1          (C(84)*F(I,NTK))*F(I,NPS2K)/RMASS(2))**2*C(85)/S8(I,K)        DT.256
       ENDDO                                                                  DT.257
      ENDDO                                                                   DT.258
C     ****                                                                    DT.259
C     ****      Add Joule heating, QJ                                         DT.260
C     ****                                                                    DT.261
C     ****       QJ = lamxx*(ui-u)**2 + (lamxy-lamyx)*(ui-u)*                 DT.262
C     ****        (vi-v) + lamyy*(vi-v)**2            (k+1/2)                 DT.263
C     ****        where:                                                      DT.264
C     ****         lam-- are elements of ion drag tensor  (1/sec)             DT.265
C     ****         u = zonal neutral velocity      (cm/sec)                   DT.266
C     ****         ui = zonal ion velocity         (cm/sec)                   DT.267
C     ****         v = meridional neutral velocity (cm/sec)                   DT.268
C     ****         ui = meridional ion velocity    (cm/sec)                   DT.269
C     ****                                                                    DT.270
C     ****       if(IUIVI = 2)then                                            DT.271
C     ****        S2 = -u                                (k+1/2)              DT.272
C     ****       else                                                         DT.273
C     ****        S2 = ui -u                                                  DT.274
C     ****       endif                                                        DT.275
C     ****       S3 is set to (vi-v) or (-v) in the same way                  DT.276
C     ****                                                                    DT.277
      NUK=NJ+NU                                                               DT.278
      NVK=NJ+NV                                                               DT.279
      NUIK=NUI                                                                DT.280
      NVIK=NVI                                                                DT.281
      DO I=1,LEN2                                                             DT.282
       S2(I,1)=.5*(F(I,NUIK)+F(I,NUIK+1))-F(I,NUK)                            DT.283
       S3(I,1)=.5*(F(I,NVIK)+F(I,NVIK+1))-F(I,NVK)                            DT.284
      ENDDO                                                                   DT.285
      NLXXK=NLXX                                                              DT.286
      NLXYK=NLXY                                                              DT.287
      NLYXK=NLYX                                                              DT.288
      NLYYK=NLYY                                                              DT.289
      DO I=1,LEN2                                                             DT.290
C      ****                                                                   DT.291
C      ****       S4 = total Joule heating                (k+1/2)             DT.292
C      ****                                                                   DT.293
       S4(I,1)=.5*(S2(I,1)**2*(F(I,NLXXK)+F(I,NLXXK+1))+S2(I,1)*              DT.294
     1         S3(I,1)*(F(I,NLXYK)+F(I,NLXYK+1)-F(I,NLYXK)-F(I,NLYXK+1))      DT.295
     2         +S3(I,1)**2*(F(I,NLYYK)+F(I,NLYYK+1)))                         DT.296
C      ****                                                                   DT.297
C      ****       Add Joule heating to S5                 (k+1/2)             DT.298
C      ****                                                                   DT.299
       S5(I,1)=S5(I,1)+S4(I,1)*3.                                             DT.300
      ENDDO                                                                   DT.301
C     ****                                                                    DT.302
C     ****        Add heating due to molecular diffusion, QM                  DT.303
C     ****                                                                    DT.304
C     ****         QM = Km/(rho*H**2)*((du/ds)**2+(dv/ds)**2) (ergs/gm)       DT.305
C     ****                                                                    DT.306
C     ****              where Km = molecular viscosity (gm/cm/sec)   (5)      DT.307
C     ****                                                                    DT.308
C     ****         S10 = du/ds,  S11 = dv/ds                   (k+1/2)        DT.309
C     ****                                                                    DT.310
C     ****          Levels 2 (k = 5/2) through KMAX-1 (k = K-3/2)             DT.311
C     ****                                                                    DT.312
C     ****           du/ds(k) = (u(k+1)-u(k-1))/(2*Ds)                        DT.313
C     ****           dv/ds(k) = (v(k+1)-v(k-1))/(2*Ds)                        DT.314
C     ****                                                                    DT.315
      NUK=NJ+NU                                                               DT.316
      NVK=NJ+NV                                                               DT.317
      DO K=2,KMAXM1                                                           DT.318
       NUK=NUK+1                                                              DT.319
       NVK=NVK+1                                                              DT.320
       DO I=1,IMAXP4                                                          DT.321
        S10(I,K)=(F(I,NUK+1)-F(I,NUK-1))/(2.*C(3))                            DT.322
        S11(I,K)=(F(I,NVK+1)-F(I,NVK-1))/(2.*C(3))                            DT.323
       ENDDO                                                                  DT.324
      ENDDO                                                                   DT.325
C     ****                                                                    DT.326
C     ****          Levels 1 (k = 3/2) and KMAX (k = K-1/2)                   DT.327
C     ****                                                                    DT.328
C     ****           At k = 3/2, we fit parabolas to the known values         DT.329
C     ****            of u and v at levels k = 1, k = 3/2 and k = 5/2.        DT.330
C     ****            We take the derivatives of these functions at           DT.331
C     ****            k = 3/2.                                                DT.332
C     ****            (Recall that level KMAXP1 contains the values of        DT.333
C     ****             u and v at level k = 1)                                DT.334
C     ****                                                                    DT.335
C     ****           At k = K-1/2, we make use of our upper boundary          DT.336
C     ****            condition (du/ds = dv/ds = 0 at level K) and fit a      DT.337
C     ****            parabola to levels (K+1/2), (K-1/2) and (K-3/2).        DT.338
C     ****            Taking u(K+1/2) = u(K-1/2) for the zero derivative      DT.339
C     ****            at level K, it can be shown that:                       DT.340
C     ****                                                                    DT.341
C     ****             du/ds(K-1/2) = 1/3*du/ds(K-3/2),                       DT.342
C     ****                                                                    DT.343
C     ****            and similarly for v.                                    DT.344
C     ****                                                                    DT.345
      NUK=NJ+NU                                                               DT.346
      NVK=NJ+NV                                                               DT.347
      DO I=1,IMAXP4                                                           DT.348
       S10(I,1)=(F(I,NUK)+F(I,NUK+1)/3.-4.*F(I,NUK+KMAX)/3.)/C(3)             DT.349
       S11(I,1)=(F(I,NVK)+F(I,NVK+1)/3.-4.*F(I,NVK+KMAX)/3.)/C(3)             DT.350
       S10(I,KMAX)=S10(I,KMAXM1)/3.                                           DT.351
       S11(I,KMAX)=S11(I,KMAXM1)/3.                                           DT.352
      ENDDO                                                                   DT.353
C     ****                                                                    DT.354
C     ****        From (5), we have                                           DT.355
C     ****                                                                    DT.356
C     ****         S10 = QM = g**2*M*Km/(p0*R*T*exp(-s))*(S10**2+S11**2)      DT.357
C     ****                                                       (k+1/2)      DT.358
C     ****                                                                    DT.359
      NKMK=NKM-1                                                              DT.360
      NTK=NJ+NT-1                                                             DT.361
      DO K=1,KMAX                                                             DT.362
       NKMK=NKMK+1                                                            DT.363
       NTK=NTK+1                                                              DT.364
       DO I=1,IMAXP4                                                          DT.365
        S10(I,K)=C(54)**2*S8(I,K)*                                            DT.366
     1           .5*(F(I,NKMK)+F(I,NKMK+1))/(C(81)*C(57)*EXPS(K)*             DT.367
     2           F(I,NTK))*(S10(I,K)**2+S11(I,K)**2)                          DT.368
       ENDDO                                                                  DT.369
      ENDDO                                                                   DT.370
C     ****                                                                    DT.371
C     ****        Add QM to other heat sources in S5                          DT.372
C     ****                                                                    DT.373
      DO I=1,LEN2                                                             DT.374
       S5(I,1)=S10(I,1)+S5(I,1)                                               DT.375
      ENDDO                                                                   DT.376
C     ****                                                                    DT.377
C     ****       S1 = -cp*exp(-s)*(T(k,n-1)/(2*Dt) - V.del(T(k,n))            DT.378
C     ****                                                                    DT.379
C     ****             +Q/cp)                                                 DT.380
C     ****                                                                    DT.381
C     ****          = S1 - exp(-s)*S5                          (k+1/2)        DT.382
C     ****                                                                    DT.383
      DO K=1,KMAX                                                             DT.384
       DO I=1,LEN1                                                            DT.385
        S1(I,K)=S1(I,K)-EXPS(K)*S5(I,K)                                       DT.386
       ENDDO                                                                  DT.387
      ENDDO                                                                   DT.388
C     ****                                                                    DT.389
C     ****     S2 = G = g*(kT + H**2*rho*cp*kE)/(p0*H*Ds**2)       (k)        DT.390
C     ****     S3 = F = g*(kE*H**3*rho*g/T)/(p0*2*H*Ds)            (k)        DT.391
C     ****                                                                    DT.392
C     ****      S4 = H = R*T/(M*g)                                 (k)        DT.393
C     ****      S5 = rho = p0*exp(-s)*M/(R*T)                      (k)        DT.394
C     ****      S6 = T                                             (k)        DT.395
C     ****                                                                    DT.396
C     ****       Levels 2 through (K-1)                                       DT.397
C     ****                                                                    DT.398
      NTK=NJ+NT-1                                                             DT.399
      NMSK=NJ+NMS-1                                                           DT.400
      DO K=2,KMAX                                                             DT.401
       NTK=NTK+1                                                              DT.402
       NMSK=NMSK+1                                                            DT.403
       DO I=1,LEN1                                                            DT.404
        S6(I,K)=.5*(F(I,NTK)+F(I,NTK+1))                                      DT.405
        S4(I,K)=C(57)*S6(I,K)/F(I,NMSK+1)                                     DT.406
        S5(I,K)=C(81)*C(87)*EXPS(K)/S4(I,K)                                   DT.407
        S4(I,K)=S4(I,K)/C(54)                                                 DT.408
       ENDDO                                                                  DT.409
      ENDDO                                                                   DT.410
C     ****                                                                    DT.411
C     ****       Levels 1 and K                                               DT.412
C     ****                                                                    DT.413
C     ****        (recall TB in T(KMAXP1), T(K) = T(K-1/2) )                  DT.414
C     ****                                                                    DT.415
      NTK=NJ+NT                                                               DT.416
      NMSK=NJ+NMS                                                             DT.417
      DO I=1,LEN1                                                             DT.418
       S6(I,1)=F(I,NTK+KMAX)                                                  DT.419
       S6(I,KMAXP1)=F(I,NTK+KMAXM1)                                           DT.420
       S4(I,1)=C(57)*S6(I,1)/F(I,NMSK)                                        DT.421
       S4(I,KMAXP1)=C(57)*S6(I,KMAXP1)/F(I,NMSK+KMAX)                         DT.422
       S5(I,1)=C(81)*C(87)*EXPS(1)/S4(I,1)                                    DT.423
       S5(I,KMAXP1)=C(81)*C(86)*EXPS(KMAX)/S4(I,KMAXP1)                       DT.424
       S4(I,1)=S4(I,1)/C(54)                                                  DT.425
       S4(I,KMAXP1)=S4(I,KMAXP1)/C(54)                                        DT.426
      ENDDO                                                                   DT.427
C     ****                                                                    DT.428
C     ****      S2 = G                                              (k)       DT.429
C     ****      S3 = F                                              (k)       DT.430
C     ****                                                                    DT.431
      NKTK=NKT-1                                                              DT.432
      NCPK=NCP-1                                                              DT.433
      DO K=1,KMAX                                                             DT.434
       NKTK=NKTK+1                                                            DT.435
       NCPK=NCPK+1                                                            DT.436
       DO I=1,LEN1                                                            DT.437
        S2(I,K)=C(54)*(F(I,NKTK)+S4(I,K)**2*S5(I,K)*F(I,NCPK)*                DT.438
     1          DIFT(K))/(C(81)*S4(I,K)*C(3)**2)                              DT.439
        S3(I,K)=C(54)**2*DIFT(K)*S4(I,K)**2*S5(I,K)/                          DT.440
     1          (S6(I,K)*C(81)*2.*C(3))                                       DT.441
       ENDDO                                                                  DT.442
      ENDDO                                                                   DT.443
C     ****                                                                    DT.444
C     ****     S9 = -P                                          (k+1/2)       DT.445
C     ****     S10 = -Q                                         (k+1/2)       DT.446
C     ****     S11 = -R                                         (k+1/2)       DT.447
C     ****     S12 = -S                                         (k+1/2)       DT.448
C     ****                                                                    DT.449
C     ****      (See (2) above for definitions of P, Q, R and S)              DT.450
C     ****                                                                    DT.451
C     ****        Levels 3/2 through K-3/2                                    DT.452
C     ****                                                                    DT.453
      DO I=1,LEN2-LEN1                                                        DT.454
       S9(I,1)=S2(I,1)-S3(I,1)                                                DT.455
       S10(I,1)=-S2(I,1)-S2(I,2)-S3(I,1)+S3(I,2)                              DT.456
       S11(I,1)=S2(I,2)+S3(I,2)                                               DT.457
       S12(I,1)=S1(I,1)                                                       DT.458
      ENDDO                                                                   DT.459
C     ****                                                                    DT.460
C     ****     At level K-1/2, we use (4) and have                            DT.461
C     ****                                                                    DT.462
      DO I=1,LEN1                                                             DT.463
       S9(I,KMAX)=S2(I,KMAX)-S3(I,KMAX)                                       DT.464
       S10(I,KMAX)=-S2(I,KMAX)-S3(I,KMAX)                                     DT.465
       S11(I,KMAX)=0.                                                         DT.466
       S12(I,KMAX)=S1(I,KMAX)                                                 DT.467
      ENDDO                                                                   DT.468
C     ****                                                                    DT.469
C     ****                                                                    DT.470
C     ****                                                                    DT.471
C     ****     S10 = S10 - cp*exp(-s)*(1/(2*DT)+ai/cp+w*R/(cp*M))             DT.472
C     ****      to complete -Q                                 (k+1/2)        DT.473
C     ****                                                                    DT.474
C     ****     S12 = S12 + exp(-s)*ae                          (k+1/2)        DT.475
C     ****      to complete -S                                                DT.476
C     ****                                                                    DT.477
      NWTEK=NWTE                                                              DT.478
      NWTIK=NWTI                                                              DT.479
      NCPK=NCP                                                                DT.480
      NWK=NJNP+NW                                                             DT.481
      DO I=1,LEN2                                                             DT.482
C      ****                                                                   DT.483
C      ****     S13 = cp*(1/(2*Dt)+ai/cp+w*R/(cp*M))             (k+1/2)      DT.484
C      ****                                                                   DT.485
       S13(I,1)=.5*(F(I,NCPK)+F(I,NCPK+1))*(C(7)+F(I,NWTIK))+                 DT.486
     1          .5*(F(I,NWK)+F(I,NWK+1))*C(57)/S8(I,1)                        DT.487
       S12(I,1)=S12(I,1)+F(I,NWTEK)                                           DT.488
      ENDDO                                                                   DT.489
      DO K=1,KMAX                                                             DT.490
       DO I=1,LEN1                                                            DT.491
C       ****                                                                  DT.492
C       ****     S10 = S10 - exp(-s)*S13                                      DT.493
C       ****                                                                  DT.494
        S10(I,K)=S10(I,K)-EXPS(K)*S13(I,K)                                    DT.495
       ENDDO                                                                  DT.496
      ENDDO                                                                   DT.497
C     ****                                                                    DT.498
C     ****     Set boundary conditions                                        DT.499
C     ****                                                                    DT.500
      DO I=1,LEN1                                                             DT.501
C      ****                                                                   DT.502
C      ****     Lower boundary at  k=3/2                                      DT.503
C      ****      S10 = -(Q - P) = S10 - S9                                    DT.504
C      ****      S12 = -(S-2*P*TB) = S12 - 2*S9*T1                            DT.505
C      ****      S9 = P = 0.                                                  DT.506
C      ****                                                                   DT.507
       S10(I,1)=S10(I,1)-S9(I,1)                                              DT.508
       S12(I,1)=S12(I,1)-2.*S9(I,1)*T1(I)                                     DT.509
       S9(I,1)=0.                                                             DT.510
      ENDDO                                                                   DT.511
C     ****                                                                    DT.512
C     ****     Call TRSLOV to solve tridiagonal system for T(n+1).            DT.513
C     ****      Solution is placed in buffer NJNP                             DT.514
C     ****      Note: S13, S14 and S15 are used as work space although        DT.515
C     ****       only S15 is passed as a parameter.  Use is made of the       DT.516
C     ****       fact that they are contiguous in /VSCR/.                     DT.517
C     ****                                                                    DT.518
c      if(j.eq.32)then
c      do k=1,kmax
c       do i=12,45
c        write(6,*)s9(i,k),s10(i,k),S11(i,k),S12(i,k),i,k
c       enddo
c      enddo
c      endif
      NTNPK=NJNP+NT                                                           DT.519
      CALL TRSOLV(S9,S10,S11,S12,S15,F(1,NTNPK),LEN1,3,LEN1-2,KMAXP1,         DT.520
     1            1,KMAX,1)                                                   DT.521
C     ****                                                                    DT.522
C     ****                                                                    DT.523
C     ****     Filter T                                                       DT.524
C     ****                                                                    DT.525
      IF(KUT(J).LT.IMAXH)THEN                                                 DT.526
       NTNPK=NJNP+NT                                                          DT.527
       CALL FILTER(NTNPK,KMAX,KUT(J))                                         DT.528
      ENDIF                                                                   DT.529
C     ****                                                                    DT.530
C     ****     Time smoothing of T                                            DT.531
C     ****                                                                    DT.532
      NTNMK=NJ+NTNM                                                           DT.533
      NTK=NJ+NT                                                               DT.534
      NTNPK=NJNP+NT                                                           DT.535
      NTNMNK=NJNP+NTNM                                                        DT.536
      DO I=1,LEN2                                                             DT.537
C      ****                                                                   DT.538
C      ****     T(smooth) = TNMN = .5*(1.-alpha)*(TNM+TNP) + alpha*TN         DT.539
C      ****                                                                   DT.540
       F(I,NTNMNK)=C(31)*(F(I,NTNMK)+F(I,NTNPK))+C(30)*F(I,NTK)               DT.541
      ENDDO                                                                   DT.542
C     ****                                                                    DT.543
C     ****     Store lower boundary values in level KMAXP1                    DT.544
C     ****                                                                    DT.545
      NTNPK=NJNP+NT+KMAX                                                      DT.546
      DO I=1,IMAXP4                                                           DT.547
       F(I,NTNPK)=T1(I)                                                       DT.548
      ENDDO                                                                   DT.549
C     ****                                                                    DT.550
C     ****     Insert periodic points for updated T.                          DT.551
C     ****                                                                    DT.552
      NXK=NJNP+NT-1                                                           DT.553
      DO N=1,2                                                                DT.554
       DO I=1,2                                                               DT.555
        DO K=1,KMAXP1                                                         DT.556
         F(I,NXK+K)=F(IMAX+I,NXK+K)                                           DT.557
         F(IMAXP2+I,NXK+K)=F(2+I,NXK+K)                                       DT.558
        ENDDO                                                                 DT.559
       ENDDO                                                                  DT.560
       NXK=NJNP+NTNM-1                                                        DT.561
      ENDDO                                                                   DT.562
	NTNPK=NJNP+NT
        tem=0.
	do 2020 i=1,len2
c        write(6,*)F(I,NTNPK)
	if(tem.LE.F(I,NTNPK))then
	tem=F(I,NTNPK)
	met=i
c        write(6,*)tem,j
	else
	endif
2020	continue
        write(6,*)tem,j
c        pause
998	format(d16.8,2i8)
      RETURN                                                                  DT.563
      END                                                                     DT.564
C                                                                             DT.565
*DKDUV                                                                       DUV.1
      SUBROUTINE DUV                                                         DUV.2
C     ****                                                                   DUV.3
C     ****     Advances u and v one time step                                DUV.4
C     ****                                                                   DUV.5
C     ****      where u = zonal velocity (cm/sec)                            DUV.6
C     ****            v = meridional velocity (cm/sec)                       DUV.7
C     ****                                                                   DUV.8
      INCLUDE "param.h"                                                      DUV.9
      INCLUDE "buffe.h"                                                      DUV.10
      INCLUDE "const.h"                                                      DUV.11
      INCLUDE "index.h"                                                      DUV.12
      INCLUDE "phycs.h"                                                      DUV.13
      INCLUDE "start.h"                                                      DUV.14
      INCLUDE "vscrw.h"                                                      DUV.15
C     ****                                                                   DUV.16
C     ****     Work space for solving the tridiagonal                        DUV.17
C     ****     block matrix schemes for u and v at latitude J.  These        DUV.18
C     ****     variables are fed to the tridiagonal block matrix             DUV.19
C     ****     solver, BLKTRI.                                               DUV.20
C     ****                                                                   DUV.21
      DIMENSION PP(2,2,ZIMXP,ZKMXP), QQ(2,2,ZIMXP,ZKMXP),                    DUV.22
     1 RR(2,2,ZIMXP,ZKMXP), SS(2,ZIMXP,ZKMXP), BETA(2,2,ZIMXP,ZKMXP),        DUV.23
     2 GAMMA(2,2,ZIMXP,ZKMXP), YY(2,ZIMXP,ZKMXP), XX(2,ZIMXP,ZKMXP)          DUV.24
C     ****                                                                   DUV.25
C     ****     Where:                                                        DUV.26
C     ****      PP, QQ, RR, BETA and GAMMA are (2 x 2) matrices defined      DUV.27
C     ****      for k = 3/2, K-1/2, 1 and i = 3, IMAX+2, 1                   DUV.28
C     ****                                                                   DUV.29
C     ****      SS, YY and XX are two component vectors similarly            DUV.30
C     ****      defined.                                                     DUV.31
C     ****                                                                   DUV.32
C     ****     At level k and longitude i, the scheme is as follows:         DUV.33
C     ****                                                                   DUV.34
C     ****      PP(i,k)*XX(i,k-1) + QQ(i,k)*XX(i,k) + RR(i,k)*XX(i,k+1)      DUV.35
C     ****         = SS(i,k)                                                 DUV.36
C     ****                                                                   DUV.37
C     ****     BETA, GAMMA and YY are work space for intermediate            DUV.38
C     ****     values used during the course of the calculation.  The        DUV.39
C     ****     final result is returned in XX.                               DUV.40
C     ****                                                                   DUV.41
C     ****     /ZTUVLB/ contains an optional lower boundary condition        DUV.42
C     ****     for v as a function of latitude.                              DUV.43
C     ****                                                                   DUV.44
      COMMON/ZTUVLB/ VNLB(ZJMX)                                              DUV.45
C     ****                                                                   DUV.46
C     ****     The phases of the semdiurnal, diurnal and annual tides        DUV.47
C     ****     are calculated as complex numbers in EXPT, EXPT2 and          DUV.48
C     ****     EXPTA respectively.                                           DUV.49
C     ****                                                                   DUV.50
      COMPLEX*16 EXPT                                                        DUV.51
C     ****                                                                   DUV.52
C     ****     Calculate u(n+1) and v(n+1) using a finite difference         DUV.53
C     ****     approximation to the horizontal momentum equations.  The      DUV.54
C     ****     leap-frog scheme is used with vertical diffusion and          DUV.55
C     ****     and advection treated implicitly to second order              DUV.56
C     ****     accuracy.  Since the zonal and meridional momentum            DUV.57
C     ****     equations are coupled through the ion drag and Coriolis       DUV.58
C     ****     terms, the system reduces to a tridiagonal block matrix       DUV.59
C     ****     scheme,  where (2 X 2) matrices and two component vectors     DUV.60
C     ****     are used at each level.  Boundary conditions for u and v      DUV.61
C     ****     are required at the top and bottom of the model.              DUV.62
C     ****                                                                   DUV.63
C     ****     At level k, the differential equations for u and v become:    DUV.64
C     ****                                                                   DUV.65
C     ****      P(k,n)*V(k-1,n+1) + Q(k,n)*V(k,n+1) +                        DUV.66
C     ****                                                                   DUV.67
C     ****                           R(k,n)*V(k+1,n+1) = S(k,n)      (1)     DUV.68
C     ****                                                                   DUV.69
C     ****      where                                                        DUV.70
C     ****       k = vertical grid index, range k = 3/2, K-1/2, 1            DUV.71
C     ****       n = time-step index                                         DUV.72
C     ****                                                                   DUV.73
C     ****       Variables are assumed to have indices (k,n) unless          DUV.74
C     ****       otherwise stated.                                           DUV.75
C     ****                                                                   DUV.76
C     ****       P(k,n), Q(k,n), R(k,n) are (2 X 2) matrices.                DUV.77
C     ****                                                                   DUV.78
C     ****                   _      _                                        DUV.79
C     ****                  |        |                                       DUV.80
C     ****       V(k,n+1) = |u(k,n+1)|                               (2)     DUV.81
C     ****                  |        |                                       DUV.82
C     ****                  |v(k,n+1)|                                       DUV.83
C     ****                  |_      _|                   _    _              DUV.84
C     ****                                              |      |             DUV.85
C     ****       P(k,n) = -(G(k-1/2,n) + exp(-s)*w(k,n)/|1., 0.|     (3)     DUV.86
C     ****                                       (2*Ds))|0., 1.|             DUV.87
C     ****                 _                    _       |_    _|             DUV.88
C     ****                |                      |                           DUV.89
C     ****       Q(k,n) = |Q(1,1,k,n), Q(1,2,k,n)|                   (4)     DUV.90
C     ****                |                      |                           DUV.91
C     ****                |Q(2,1,k,n), Q(2,2,k,n)|                           DUV.92
C     ****                |_                    _|                           DUV.93
C     ****                                                                   DUV.94
C     ****                                                                   DUV.95
C     ****       where:                                                      DUV.96
C     ****                                                       _           DUV.97
C     ****        Q(1,1,k,n) = G(k-1/2,n) + G(k+1/2,n) + exp(-s)* |          DUV.98
C     ****                                                        |          DUV.99
C     ****         (1/(2*Dt) + lamxx(k,n))                        |          DUV.100
C     ****                                                        |          DUV.101
C     ****        Q(1,2,k,n) = -exp(-s)*(f+u/r*tan(theta)-lamxy)  |          DUV.102
C     ****                                                        |  (5)     DUV.103
C     ****        Q(2,1,k,n) = exp(-s)*(f+u/r*tan(theta)-lamyx)   |          DUV.104
C     ****                                                        |          DUV.105
C     ****        Q(2,2,k,n) = G(k-1/2,n) + G(k+1/2,n) + exp(-s)* |          DUV.106
C     ****                                                        |          DUV.107
C     ****         (1/(2*Dt) + lamyy(k,n))                       _|          DUV.108
C     ****                                                                   DUV.109
C     ****                                               _    _              DUV.110
C     ****                                              |      |             DUV.111
C     ****       R(k,n) = -(G(k+1/2,n) - exp(-s)*w(k,n)/|1., 0.|     (6)     DUV.112
C     ****                                       (2*Ds))|0., 1.|             DUV.113
C     ****                                              |_    _|             DUV.114
C     ****                                                                   DUV.115
C     ****                 _        _                                        DUV.116
C     ****                |          |                                       DUV.117
C     ****       S(k,n) = |S(1,k,n+1)|                               (7)     DUV.118
C     ****                |          |                                       DUV.119
C     ****                |S(2,k,n+1)|                                       DUV.120
C     ****                |_        _|                                       DUV.121
C     ****                                                                   DUV.122
C     ****       where:                                                      DUV.123
C     ****                                                          _        DUV.124
C     ****        S(1,k,n) = exp(-s)*(u(n-1,k)/(2*Dt) - V.del(u) -   |       DUV.125
C     ****                                                           |       DUV.126
C     ****         g/(r*cos(theta))*dz/d(lamda) + lamxx*ui +         |       DUV.127
C     ****                                                           |       DUV.128
C     ****         lamxy*vi + FLH + GWU)                             |       DUV.129
C     ****                                                           (8)     DUV.130
C     ****                                                           |       DUV.131
C     ****        S(2,k,n) = exp(-s)*(v(n-1,k)/(2*Dt) - V.del(v) -   |       DUV.132
C     ****                                                           |       DUV.133
C     ****         g/r*dz/d(theta) - lamyx*ui + lamyy*vi + FPH + GWV)|       DUV.134
C     ****                                                          _|       DUV.135
C     ****                                                                   DUV.136
C     ****        G = g*KM/(P0*H*Ds**2)                                      DUV.137
C     ****                                                                   DUV.138
C     ****        KM = kM + ke = kM + XMUE                   (gm/cm/sec)     DUV.139
C     ****                                                                   DUV.140
C     ****        kM = vertical molecular viscosity          (gm/cm/sec)     DUV.141
C     ****                                                                   DUV.142
C     ****        ke = vertical eddy diffusion               (gm/cm/sec)     DUV.143
C     ****                                                                   DUV.144
C     ****        u = zonal neutral velocity                    (cm/sec)     DUV.145
C     ****                                                                   DUV.146
C     ****        v = meridional neutral velocity               (cm/sec)     DUV.147
C     ****                                                                   DUV.148
C     ****        ui = zonal ion velocity                       (cm/sec)     DUV.149
C     ****                                                                   DUV.150
C     ****        vi = meridional ion velocity                  (cm/sec)     DUV.151
C     ****                                                                   DUV.152
C     ****        V.del(u) = horizontal advection of u       (cm/sec**2)     DUV.153
C     ****                                                                   DUV.154
C     ****        V.del(v) = horizontal advection of v       (cm/sec**2)     DUV.155
C     ****                                                                   DUV.156
C     ****        lamda = longitude                            (radians)     DUV.157
C     ****                                                                   DUV.158
C     ****        theta = latitude                             (radians)     DUV.159
C     ****                                                                   DUV.160
C     ****        r = earth's radius                                (cm)     DUV.161
C     ****                                                                   DUV.162
C     ****        s = dimensionless vertical pressure coordinate             DUV.163
C     ****                                                                   DUV.164
C     ****        Ds = grid spacing for vertical dimensionless               DUV.165
C     ****             coordinate ( = 1/2)                                   DUV.166
C     ****                                                                   DUV.167
C     ****        t = time                                     (seconds)     DUV.168
C     ****                                                                   DUV.169
C     ****        Dt = time step for leap-frog integration     (seconds)     DUV.170
C     ****             (typically 180 to 360 seconds)                        DUV.171
C     ****        _           _                                              DUV.172
C     ****       |             |                                             DUV.173
C     ****       |lamxx,  lamxy|                                             DUV.174
C     ****       |             | = ion drag tensor               (1/sec)     DUV.175
C     ****       |-lamyx, lamyy|                                             DUV.176
C     ****       |_           _|                                             DUV.177
C     ****                                                                   DUV.178
C     ****                                                                   DUV.179
C     ****      Boundary conditions:                                         DUV.180
C     ****                                                                   DUV.181
C     ****       Lower boundary:                                             DUV.182
C     ****                                                                   DUV.183
C     ****        The lower boundary of the model is at (k = 1) where        DUV.184
C     ****        u and v are given in one of two ways:                      DUV.185
C     ****                                                                   DUV.186
C     ****         a) The sum of semidiurnal, diurnal and annual tidal       DUV.187
C     ****            perturbations, ub and vb                               DUV.188
C     ****                                                                   DUV.189
C     ****         b) Boundary conditions given by output from another       DUV.190
C     ****            model e.g. CCM.  The boundaries are again given        DUV.191
C     ****            by ub and vb for the zonal and meridional              DUV.192
C     ****            velocities respectively.                               DUV.193
C     ****                                                                   DUV.194
C     ****        These boundary conditions are described by:                DUV.195
C     ****                                                                   DUV.196
C     ****         ub = .5*(u(1/2) + u(3/2))                                 DUV.197
C     ****                                                                   DUV.198
C     ****        or                                                         DUV.199
C     ****                                                                   DUV.200
C     ****         u(1/2) = 2*ub - u(3/2)                                    DUV.201
C     ****                                                                   DUV.202
C     ****        Similarly                                                  DUV.203
C     ****                                                                   DUV.204
C     ****         v(1/2) = 2*vb - v(3/2)                                    DUV.205
C     ****                                                                   DUV.206
C     ****        Or in vector form                                          DUV.207
C     ****                                                                   DUV.208
C     ****         V(1/2) = 2*Vb -V(3/2)                             (9)     DUV.209
C     ****                                                                   DUV.210
C     ****                                                                   DUV.211
C     ****        Substituting (9) in (1) for k = 3/2 gives:                 DUV.212
C     ****                                                                   DUV.213
C     ****         (Q(3/2,n)-P(3/2,n))*V(3/2,n+1) + R(3/2,n)*V(5/3,n+1)      DUV.214
C     ****                                                                   DUV.215
C     ****                          = S(3/2,n)-2.*P(3/2,n)*Vb       (10)     DUV.216
C     ****                                                                   DUV.217
C     ****       Upper boundary:                                             DUV.218
C     ****                                                                   DUV.219
C     ****        The upper boundary is at level k = K, where the            DUV.220
C     ****        vertical derivatives of u and v are zero.  This            DUV.221
C     ****        translates to:                                             DUV.222
C     ****                                                                   DUV.223
C     ****         V(K+1/2,n+1) = V(K-1/2,n+1)                      (11)     DUV.224
C     ****                                                                   DUV.225
C     ****        Substituting (11) in (1) for k = K-1/2 gives:              DUV.226
C     ****                                                                   DUV.227
C     ****         P(K-1/2,n)*V(K-3/2,n+1) + (Q(K-1/2,n)+R(K-1/2,n))*        DUV.228
C     ****                                                                   DUV.229
C     ****                    V(K-1/2,n+1) = S(K-1/2,n)             (12)     DUV.230
C     ****                                                                   DUV.231
C     ****     Now start calculation                                         DUV.232
C     ****                                                                   DUV.233
C     ****      Evaluate tidal boundary condition for u and v.  This         DUV.234
C     ****      includes semidiurnal, diurnal and annual tides.              DUV.235
C     ****                                                                   DUV.236
C     ****       T1 = zonal velocity at lower boundary          (cm/sec)     DUV.237
C     ****       T2 = meridional velocity at lower boundary     (cm/sec)     DUV.238
C     ****                                                                   DUV.239
C     ****       EXPT = exp(i*nusd*t)     (time varying factor for           DUV.240
C     ****                                             semidiurnal tide)     DUV.241
C     ****                                                                   DUV.242
C     ****        where i = sqrt(-1)                                         DUV.243
C     ****              nusd = semidiurnal frequency       (radians/sec)     DUV.244
C     ****              t = current model time                 (seconds)     DUV.245
C     ****                                                                   DUV.246
C     ****         Lower Boundary Conditions                                 DUV.247
C     ****                                                                   DUV.248
      EXPT=CDEXP(CI*C(23)*C(4)*DBLE(ITER))                                   DUV.249
      DO I=1,LEN1                                                            DUV.250
       T1(I)=DREAL(UB(J)*BND(I)*EXPT)                                        DUV.251
       T2(I)=DREAL(VB(J)*BND(I)*EXPT)                                        DUV.252
      ENDDO                                                                  DUV.253
      EXPT=CDEXP(CI*.5*C(23)*C(4)*DBLE(ITER))                                DUV.254
      DO I=1,LEN1                                                            DUV.255
       T1(I)=T1(I)+DREAL(UB2(J)*BND2(I)*EXPT)                                DUV.256
       T2(I)=T2(I)+DREAL(VB2(J)*BND2(I)*EXPT)                                DUV.257
      ENDDO                                                                  DUV.258
      EXPT=(1.,0.)                                                           DUV.259
      DO I=1,LEN1                                                            DUV.260
       T1(I)=T1(I)+DREAL(UBA(J)*BNDA(I)*EXPT)                                DUV.261
       T2(I)=T2(I)+DREAL(VBA(J)*BNDA(I)*EXPT)                                DUV.262
      ENDDO                                                                  DUV.263
C     ****                                                                   DUV.264
C     ****     S1 = horizontal advection of u               (k+1/2)          DUV.265
C     ****                                                                   DUV.266
C     ****        = (u/(r*cos(theta)))*du/d(lamda) + (v/r)du/d(theta)        DUV.267
C     ****                                                                   DUV.268
C     ****     (using 4th order difference approximation)                    DUV.269
C     ****     Note: The pointer, NU, giving the postion of the zonal        DUV.270
C     ****     velocity field in the F-array, is passed to subroutine        DUV.271
C     ****     ADVEC)                                                        DUV.272
C     ****     Warning:  ADVEC uses work arrays S11 - S15  in /VSCR/         DUV.273
C     ****                                                                   DUV.274
      CALL ADVEC(NU,S1)                                                      DUV.275
C     ****                                                                   DUV.276
C     ****     Similarly for v in S2                                         DUV.277
C     ****                                                                   DUV.278
      CALL ADVEC(NV,S2)                                                      DUV.279
C     ****                                                                   DUV.280
C     ****     Calculate horizontal pressure forces in S14 and S15           DUV.281
C     ****                                                                   DUV.282
C     ****      S14 = g/(r*cos(theta))*dz/d(lamda)          (k+1/2)          DUV.283
C     ****                                                                   DUV.284
C     ****      S15 = (g/r)*dz/d(theta)                     (k+1/2)          DUV.285
C     ****                                                                   DUV.286
C     ****      where z = geopotential height                                DUV.287
C     ****                                                                   DUV.288
C     ****     Warning: GLP uses S6 and S7                                   DUV.289
C     ****                                                                   DUV.290
      CALL GLP(S14,S15)                                                      DUV.291
C     ****                                                                   DUV.292
C     ****     S1 = V.del(u) + g/(r*cos(theta))*dz/d(lamda) - FLH            DUV.293
C     ****                                                                   DUV.294
C     ****     S2 = V.del(v) + (g/r)*dz/d(theta) - FLP                       DUV.295
C     ****                                                                   DUV.296
C     ****     where FLH and FPH are 4th order horizontal diffusion          DUV.297
C     ****     terms.  GWU and GWV  are gravity wave drag terms.             DUV.298
C     ****                                                                   DUV.299
      NFLHK=NFLH                                                             DUV.300
      NFPHK=NFPH                                                             DUV.301
      DO I=1,LEN2                                                            DUV.302
       S1(I,1) = S1(I,1) + S14(I,1) - F(I,NFLHK)                             DUV.303
       S2(I,1) = S2(I,1) + S15(I,1) - F(I,NFPHK)                             DUV.304
      ENDDO                                                                  DUV.305
C     ****                                                                   DUV.306
C     ****     Operate Shapiro smoother on u(n-1) and v(n-1) in              DUV.307
C     ****     two stages.                                                   DUV.308
C     ****                                                                   DUV.309
C     ****      First latitudinal smoothing for u with results to S6         DUV.310
C     ****                                                                   DUV.311
      NUJP2K=NJP2+NUNM                                                       DUV.312
      NUJP1K=NJP1+NUNM                                                       DUV.313
      NUNMK=NJ+NUNM                                                          DUV.314
      NUJM1K=NJM1+NUNM                                                       DUV.315
      NUJM2K=NJM2+NUNM                                                       DUV.316
      DO I=1,LEN2                                                            DUV.317
       S6(I,1)=F(I,NUNMK)-C(26)*(F(I,NUJP2K)+F(I,NUJM2K)-4.*                 DUV.318
     1         (F(I,NUJP1K)+F(I,NUJM1K))+6.*F(I,NUNMK))                      DUV.319
      ENDDO                                                                  DUV.320
C     ****                                                                   DUV.321
C     ****      Now longitudinal smoothing for u with results to S7          DUV.322
C     ****                                                                   DUV.323
      DO I=3,LEN2-2                                                          DUV.324
       S7(I,1)=S6(I,1)-C(26)*(S6(I+2,1)+S6(I-2,1)-4.*                        DUV.325
     1         (S6(I+1,1)+S6(I-1,1))+6.*S6(I,1))                             DUV.326
C      ****                                                                  DUV.327
C      ****     S1 = V.del(u) + g/(r*cos(theta))*dz/d(lamda) - FLH -         DUV.328
C      ****          1./(2*Dt)*u(n-1)                    (k+1/2)             DUV.329
C      ****                                                                  DUV.330
C      ****        = S1 - 1/(2*Dt)*S7                          (k+1/2)       DUV.331
C      ****                                                                  DUV.332
       S1(I,1)=S1(I,1)-C(7)*S7(I,1)                                          DUV.333
      ENDDO                                                                  DUV.334
C     ****                                                                   DUV.335
C     ****     Now do v                                                      DUV.336
C     ****                                                                   DUV.337
C     ****      First latitudinal smoothing for v with results to S6         DUV.338
C     ****                                                                   DUV.339
      NVJP2K=NJP2+NVNM                                                       DUV.340
      NVJP1K=NJP1+NVNM                                                       DUV.341
      NVNMK=NJ+NVNM                                                          DUV.342
      NVJM1K=NJM1+NVNM                                                       DUV.343
      NVJM2K=NJM2+NVNM                                                       DUV.344
      DO I=1,LEN2                                                            DUV.345
       S6(I,1)=F(I,NVNMK)-C(26)*(F(I,NVJP2K)+F(I,NVJM2K)-4.*                 DUV.346
     1         (F(I,NVJP1K)+F(I,NVJM1K))+6.*F(I,NVNMK))                      DUV.347
      ENDDO                                                                  DUV.348
C     ****                                                                   DUV.349
C     ****      Now longitudinal smoothing for v with results to S7          DUV.350
C     ****                                                                   DUV.351
      DO I=3,LEN2-2                                                          DUV.352
       S7(I,1)=S6(I,1)-C(26)*(S6(I+2,1)+S6(I-2,1)-4.*                        DUV.353
     1         (S6(I+1,1)+S6(I-1,1))+6.*S6(I,1))                             DUV.354
C      ****                                                                  DUV.355
C      ****     S2 = V.del(v) + (g/r)*dz/d(theta) - FPH -                    DUV.356
C      ****          1./(2*Dt)*v(n-1)                    (k+1/2)             DUV.357
C      ****                                                                  DUV.358
C      ****        = S2 - 1/(2*Dt)*S7                          (k+1/2)       DUV.359
C      ****                                                                  DUV.360
       S2(I,1) = S2(I,1) - C(7)*S7(I,1)                                      DUV.361
      ENDDO                                                                  DUV.362
C     ****                                                                   DUV.363
C     ****     SS(1) = exp(-s)*(u(n-1,k)/(2*Dt) - V.del(u) -                 DUV.364
C     ****                                                                   DUV.365
C     ****             g/(r*cos(theta))*dz/d(lamda) + lamxx*ui +             DUV.366
C     ****                                                                   DUV.367
C     ****             lamxy*vi + FLH + GWU)                                 DUV.368
C     ****                                                                   DUV.369
C     ****           = exp(-s)*(lamxx*ui + lamxy*vi -S1)                     DUV.370
C     ****                                                                   DUV.371
C     ****                                                                   DUV.372
C     ****     SS(2) = exp(-s)*(v(n-1,k)/(2*Dt) - V.del(v) -                 DUV.373
C     ****                                                                   DUV.374
C     ****             g/r*dz/d(theta) - lamyx*ui + lamyy*vi +               DUV.375
C     ****                                                                   DUV.376
C     ****             FPH + GWV)                                            DUV.377
C     ****                                                                   DUV.378
C     ****           = exp(-s)*(lamyy*ui - lamyx*ui -S2)                     DUV.379
C     ****                                                                   DUV.380
      NUIK=NUI-1                                                             DUV.381
      NVIK=NVI-1                                                             DUV.382
      NLXXK=NLXX-1                                                           DUV.383
      NLXYK=NLXY-1                                                           DUV.384
      NLYXK=NLYX-1                                                           DUV.385
      NLYYK=NLYY-1                                                           DUV.386
      DO K=1,KMAX                                                            DUV.387
       NUIK=NUIK+1                                                           DUV.388
       NVIK=NVIK+1                                                           DUV.389
       NLXXK=NLXXK+1                                                         DUV.390
       NLXYK=NLXYK+1                                                         DUV.391
       NLYXK=NLYXK+1                                                         DUV.392
       NLYYK=NLYYK+1                                                         DUV.393
       DO I=1,LEN1                                                           DUV.394
        SS(1,I,K)=EXPS(K)*(.25*((F(I,NLXXK)+F(I,NLXXK+1))*                   DUV.395
     1            (F(I,NUIK)+F(I,NUIK+1))+(F(I,NLXYK)+F(I,NLXYK+1))*         DUV.396
     2            (F(I,NVIK)+F(I,NVIK+1)))-S1(I,K))                          DUV.397
        SS(2,I,K)=EXPS(K)*(.25*((F(I,NLYYK)+F(I,NLYYK+1))*                   DUV.398
     1            (F(I,NVIK)+F(I,NVIK+1))-(F(I,NLYXK)+F(I,NLYXK+1))*         DUV.399
     2            (F(I,NUIK)+F(I,NUIK+1)))-S2(I,K))                          DUV.400
       ENDDO                                                                 DUV.401
      ENDDO                                                                  DUV.402
C     ****                                                                   DUV.403
C     ****      S1 = G = g*KM/(P0*H*Ds**2)                                   DUV.404
C     ****                                                                   DUV.405
C     ****             = g**2*(kM+XMUE)*MBAR*/(P0*R*T*DS**2)                 DUV.406
C     ****                                                                   DUV.407
C     ****       S1 = T(k)                                                   DUV.408
C     ****       T3 = XMUE(k)                                                DUV.409
C     ****                                                                   DUV.410
C     ****        Levels 2 thru KMAX                                         DUV.411
C     ****                                                                   DUV.412
      NTK=NJ+NT-1                                                            DUV.413
      DO K=2,KMAX                                                            DUV.414
       NTK=NTK+1                                                             DUV.415
       T3(K)=DSQRT(XMUE(K-1)*XMUE(K))                                        DUV.416
       DO I=1,LEN1                                                           DUV.417
        S1(I,K)=.5*(F(I,NTK)+F(I,NTK+1))                                     DUV.418
       ENDDO                                                                 DUV.419
      ENDDO                                                                  DUV.420
C     ****                                                                   DUV.421
C     ****        Levels 1 and  KMAXP1                                       DUV.422
C     ****                                                                   DUV.423
C     ****         Note: Vertical gradient of T is zero at upper             DUV.424
C     ****         boundary.  Value of T at lower boundary is stored in      DUV.425
C     ****         F(I,NTK)  at level KMAXP1.                                DUV.426
C     ****                                                                   DUV.427
      NTK=NJ+NT                                                              DUV.428
      T3(1)=DSQRT(XMUE(1)**3/XMUE(2))                                        DUV.429
      T3(KMAXP1)=DSQRT(XMUE(KMAX)**3/XMUE(KMAX-1))                           DUV.430
      DO I=1,LEN1                                                            DUV.431
       S1(I,1)=F(I,NTK+KMAX)                                                 DUV.432
       S1(I,KMAXP1)=F(I,NTK+KMAX-1)                                          DUV.433
      ENDDO                                                                  DUV.434
C     ****                                                                   DUV.435
C     ****      Now complete S1 = G                                          DUV.436
C     ****                                                                   DUV.437
      NKMK=NKM-1                                                             DUV.438
      NMSK=NJ+NMS-1                                                          DUV.439
      DO K=1,KMAXP1                                                          DUV.440
       NKMK=NKMK+1                                                           DUV.441
       NMSK=NMSK+1                                                           DUV.442
       DO I=1,LEN1                                                           DUV.443
        S1(I,K)=C(54)**2*(F(I,NKMK)+T3(K))*                                  DUV.444
     1          F(I,NMSK)/(C(81)*C(57)*S1(I,K)*C(3)**2)                      DUV.445
       ENDDO                                                                 DUV.446
      ENDDO                                                                  DUV.447
C     ****                                                                   DUV.448
C     ****     S2 = exp(-s)*w(k+1/2)/(2.*Ds)                                 DUV.449
C     ****                                                                   DUV.450
      NWK=NJNP+NW-1                                                          DUV.451
      DO K=1,KMAX                                                            DUV.452
       NWK=NWK+1                                                             DUV.453
       DO I=1,LEN1                                                           DUV.454
        S2(I,K)=0.5*EXPS(K)*(F(I,NWK)+F(I,NWK+1))/(2.*C(3))                  DUV.455
       ENDDO                                                                 DUV.456
      ENDDO                                                                  DUV.457
C     ****                                                                   DUV.458
C     ****     Now evaluate:                          _    _                 DUV.459
C     ****                                           |      |                DUV.460
C     ****      P = -(G(k-1/2,n) + exp(-s)*w(k,n)/   |1., 0.|                DUV.461
C     ****                                 (2.*Ds)) *|0., 1.|                DUV.462
C     ****                                           |_    _|                DUV.463
C     ****                                                                   DUV.464
C     ****       and                                                         DUV.465
C     ****                                            _    _                 DUV.466
C     ****                                           |      |                DUV.468
C     ****      R = -(G(k+1/2,n) - exp(-s)*w(k,n)/   |1., 0.|                DUV.469
C     ****                                 (2.*Ds)) *|0., 1.|                DUV.470
C     ****                                           |_    _|                DUV.471
C     ****       for k = 3/2, K-1/2, 1                                       DUV.472
C     ****                                                                   DUV.473
      DO K=1,KMAX                                                            DUV.474
       DO I=1,LEN1                                                           DUV.475
        PP(1,1,I,K)=-(S1(I,K) + S2(I,K))                                     DUV.476
        RR(1,1,I,K)=-(S1(I,K+1) - S2(I,K))                                   DUV.477
        PP(2,2,I,K)=PP(1,1,I,K)                                              DUV.478
        RR(2,2,I,K)=RR(1,1,I,K)                                              DUV.479
        PP(1,2,I,K)=0.                                                       DUV.480
        RR(1,2,I,K)=0.                                                       DUV.481
        PP(2,1,I,K)=0.                                                       DUV.482
        RR(2,1,I,K)=0.                                                       DUV.483
        ENDDO                                                                DUV.484
      ENDDO                                                                  DUV.485
C     ****                                                                   DUV.486
C     ****     Now calculate Q from (5) for k = 3/2, K-1/2, 1                DUV.487
C     ****                                                                   DUV.488
C     ****      First do:                                                    DUV.489
C     ****                                                                   DUV.490
C     ****       Q(1,1,k) = G(k-1/2) + G(k+1/2) + exp(-s)*(1./(2.*Dt) +      DUV.491
C     ****                  lamxx(k))                                        DUV.492
C     ****        and                                                        DUV.493
C     ****                                                                   DUV.494
C     ****       Q(2,2,k) = G(k-1/2) + G(k+1/2) + exp(-s)*(1./(2.*Dt) +      DUV.495
C     ****                  lamyy(k))                                        DUV.496
C     ****                                                                   DUV.497
      NLXXK=NLXX-1                                                           DUV.498
      NLYYK=NLYY-1                                                           DUV.499
      NLXYK=NLXY-1                                                           DUV.500
      NLYXK=NLYX-1                                                           DUV.501
      NUK=NJ+NU-1                                                            DUV.502
      DO K=1,KMAX                                                            DUV.503
       NLXXK=NLXXK+1                                                         DUV.504
       NLYYK=NLYYK+1                                                         DUV.505
       NLXYK=NLXYK+1                                                         DUV.506
       NLYXK=NLYXK+1                                                         DUV.507
       NUK=NUK+1                                                             DUV.508
       DO I=1,LEN1                                                           DUV.509
        QQ(1,1,I,K)=S1(I,K)+S1(I,K+1)                                        DUV.510
        QQ(2,2,I,K)=QQ(1,1,I,K)                                              DUV.511
        QQ(1,1,I,K)=QQ(1,1,I,K)+EXPS(K)*(C(7)+.5*(F(I,NLXXK)+                DUV.512
     1              F(I,NLXXK+1)))                                           DUV.513
        QQ(2,2,I,K)=QQ(2,2,I,K)+EXPS(K)*(C(7)+.5*(F(I,NLYYK)+                DUV.514
     1              F(I,NLYYK+1)))                                           DUV.515
C       ****                                                                 DUV.516
C       ****     Now do:                                                     DUV.517
C       ****                                                                 DUV.518
C       ****      Q(1,2) = -exp(-s) * (f+u/r*tan(theta)-lamxy)               DUV.519
C       ****                                                                 DUV.520
C       ****       and                                                       DUV.521
C       ****                                                                 DUV.522
C       ****      Q(2,1) = exp(-s) * (f+u/r*tan(theta)-lamyx)                DUV.523
C       ****                                                                 DUV.524
        QQ(1,2,I,K)=COR(J)+F(I,NUK)/C(51)*TN(J)                              DUV.525
        QQ(2,1,I,K)=QQ(1,2,I,K)                                              DUV.526
        QQ(1,2,I,K)=-EXPS(K)*(QQ(1,2,I,K)-.5*(F(I,NLXYK)+F(I,NLXYK+1)))      DUV.527
        QQ(2,1,I,K)=EXPS(K)*(QQ(2,1,I,K)-.5*(F(I,NLYXK)+F(I,NLYXK+1)))       DUV.528
       ENDDO                                                                 DUV.529
      ENDDO                                                                  DUV.530
C     ****                                                                   DUV.531
C     ****     Now set boundary conditions at  k = 3/2 and k = K-1/2         DUV.532
C     ****                                                                   DUV.533
      DO I = 1,LEN1                                                          DUV.534
C      ****                                                                  DUV.535
C      ****      Lower boundary:                                             DUV.536
C      ****                                                                  DUV.537
C      ****       From (10):                                                 DUV.538
C      ****                                                                  DUV.539
C      ****        Q(3/2) = Q(3/2) - P(3/2)                                  DUV.540
C      ****        S(3/2) = S(3/2) -2.*P(3/2)*Vb                             DUV.541
C      ****        P(3/2) = 0.                                               DUV.542
C      ****                                                                  DUV.543
       QQ(1,1,I,1)=QQ(1,1,I,1)-PP(1,1,I,1)                                   DUV.544
       QQ(1,2,I,1)=QQ(1,2,I,1)-PP(1,2,I,1)                                   DUV.545
       QQ(2,1,I,1)=QQ(2,1,I,1)-PP(2,1,I,1)                                   DUV.546
       QQ(2,2,I,1)=QQ(2,2,I,1)-PP(2,2,I,1)                                   DUV.547
       SS(1,I,1)=SS(1,I,1)-2.*(PP(1,1,I,1)*T1(I)+PP(1,2,I,1)*T2(I))          DUV.548
       SS(2,I,1)=SS(2,I,1)-2.*(PP(2,1,I,1)*T1(I)+PP(2,2,I,1)*T2(I))          DUV.549
       PP(1,1,I,1)=0.                                                        DUV.550
       PP(1,2,I,1)=0.                                                        DUV.551
       PP(2,1,I,1)=0.                                                        DUV.552
       PP(2,2,I,1)=0.                                                        DUV.553
C      ****                                                                  DUV.554
C      ****      Upper boundary:                                             DUV.555
C      ****                                                                  DUV.556
C      ****       From (12):                                                 DUV.557
C      ***                                                                   DUV.558
C      ****        Q(K-1/2) = Q(K-1/2) + R(K-1/2)                            DUV.559
C      ****        R(K-1/2) = 0.                                             DUV.560
C      ****                                                                  DUV.561
       QQ(1,1,I,KMAX)=QQ(1,1,I,KMAX)+RR(1,1,I,KMAX)                          DUV.562
       QQ(1,2,I,KMAX)=QQ(1,2,I,KMAX)+RR(1,2,I,KMAX)                          DUV.563
       QQ(2,1,I,KMAX)=QQ(2,1,I,KMAX)+RR(2,1,I,KMAX)                          DUV.564
       QQ(2,2,I,KMAX)=QQ(2,2,I,KMAX)+RR(2,2,I,KMAX)                          DUV.565
       RR(1,1,I,KMAX)=0.                                                     DUV.566
       RR(1,2,I,KMAX)=0.                                                     DUV.567
       RR(2,1,I,KMAX)=0.                                                     DUV.568
       RR(2,2,I,KMAX)=0.                                                     DUV.569
      ENDDO                                                                  DUV.570
C     ****                                                                   DUV.571
C     ****     Call BLKTRI to solve the tridiagonal (2 x 2) block matrix     DUV.572
C     ****     for u and v.                                                  DUV.573
C     ****                                                                   DUV.574
      CALL BLKTRI(PP,QQ,RR,SS,LEN1,3,IMAX+2,KMAXP1,1,KMAX,BETA,GAMMA,        DUV.575
     1            YY,XX)                                                     DUV.576
C     ****                                                                   DUV.577
C     ****     Store updated u and v.                                        DUV.578
C     ****                                                                   DUV.579
      NUK=NJNP+NU-1                                                          DUV.580
      NVK=NJNP+NV-1                                                          DUV.581
      DO K=1,KMAX                                                            DUV.582
       NUK=NUK+1                                                             DUV.583
       NVK=NVK+1                                                             DUV.584
       DO I=3,IMAX+2                                                         DUV.585
        F(I,NUK)=XX(1,I,K)                                                   DUV.586
        F(I,NVK)=XX(2,I,K)                                                   DUV.587
       ENDDO                                                                 DUV.588
      ENDDO                                                                  DUV.589
C     ****                                                                   DUV.590
C     ****     Store lower boundary conditions for u and v at                DUV.591
C     ****     level (KMAX+1)                                                DUV.592
C     ****                                                                   DUV.593
      NUK=NJNP+NU+KMAX                                                       DUV.594
      NVK=NJNP+NV+KMAX                                                       DUV.595
      DO I=3,IMAX+2                                                          DUV.596
       F(I,NUK)=T1(I)                                                        DUV.597
       F(I,NVK)=T2(I)                                                        DUV.598
      ENDDO                                                                  DUV.599
C     ****                                                                   DUV.600
C     ****     Fourier smoothing of u and v                                  DUV.601
C     ****                                                                   DUV.602
      IF(KUT(J).LT.IMAXH)THEN                                                DUV.603
       NUNPK=NJNP+NU                                                         DUV.604
       NVNPK=NJNP+NV                                                         DUV.605
       CALL FILTER(NUNPK,KMAX,KUT(J))                                        DUV.606
       CALL FILTER(NVNPK,KMAX,KUT(J))                                        DUV.607
      ENDIF                                                                  DUV.608
C     ****                                                                   DUV.609
C     ****     Time smoothing u and v                                        DUV.610
C     ****                                                                   DUV.611
      NUNMK=NJ+NUNM                                                          DUV.612
      NUK=NJ+NU                                                              DUV.613
      NUNPK=NJNP+NU                                                          DUV.614
      NUNMNK=NJNP+NUNM                                                       DUV.615
      NVNMK=NJ+NVNM                                                          DUV.616
      NVK=NJ+NV                                                              DUV.617
      NVNPK=NJNP+NV                                                          DUV.618
      NVNMNK=NJNP+NVNM                                                       DUV.619
      DO I=1,LEN2                                                            DUV.620
C      ****                                                                  DUV.621
C      ****     u(n,smooth) = UNMN = .5*(1.-alpha)*(u(n-1)+u(n+1)) +         DUV.622
C      ****                          alpha*u(n)                              DUV.623
C      ****                                                                  DUV.624
       F(I,NUNMNK)=C(31)*(F(I,NUNMK)+F(I,NUNPK))+C(30)*F(I,NUK)              DUV.625
C      ****                                                                  DUV.626
C      ****     and similarly for v                                          DUV.627
C      ****                                                                  DUV.628
C      ****                                                                  DUV.629
       F(I,NVNMNK)=C(31)*(F(I,NVNMK)+F(I,NVNPK))+C(30)*F(I,NVK)              DUV.630
      ENDDO                                                                  DUV.631
C     ****                                                                   DUV.632
C     ****     Periodic points for u and v                                   DUV.633
C     ****                                                                   DUV.634
      NXK=NJNP+NU-1                                                          DUV.635
      DO N=1,2                                                               DUV.636
       DO I=1,2                                                              DUV.637
        DO K=1,2*KMAXP1                                                      DUV.638
         F(I,NXK+K)=F(I+IMAX,NXK+K)                                          DUV.639
         F(I+IMAXP2,NXK+K)=F(I+2,NXK+K)                                      DUV.640
        ENDDO                                                                DUV.641
       ENDDO                                                                 DUV.642
       NXK=NJNP+NUNM-1                                                       DUV.643
      ENDDO                                                                  DUV.644
      umax=0.
      vmax=0.
      uimax=0.
      vimax=0.
      nuik=nui
      nvik=nvi
      NUNPK=NJNP+NU  
      NVNPK=NJNP+NV        
      do k=1,kmax
       do i=10,len1-9
c        if(umax.le.dabs(F(I,NUNPK)))umax=dabs(F(I,NUNPK))
c        if(vmax.le.dabs(F(I,NvNPK)))vmax=dabs(F(I,NvNPK))   
c        if(uimax.le.dabs(F(I,NUiK)))uimax=dabs(F(I,NUiK))
c        if(vimax.le.dabs(F(I,NviK)))vimax=dabs(F(I,NviK)) 
c        write(6,*)F(I,NUNPK),F(I,NvNPK),F(I,NUiK),F(I,NviK),i,k
       enddo
       NUNPK=NUNPK+1
       NvNPK=NvNPK+1
       nuik=nuik+1
       nvik=nvik+1
      enddo
c      pause
c      if(j.ge.22.and.j.le.35)write(6,*)umax,vmax,uimax,vimax
      RETURN                                                                 DUV.645
      END                                                                    DUV.646
C                                                                            DUV.647
*DK ELDEN                                                                  ELDEN.1
      SUBROUTINE ELDEN                                                     ELDEN.2
C     ****                                                                 ELDEN.3
C     ****     CALCULATES ELECTRON DENSITY AND ION NUMBER DENSITIES        ELDEN.4
C     ****                                                                 ELDEN.5
      INCLUDE 'param.h'                                                    ELDEN.6
      INCLUDE 'vscrw.h'                                                    ELDEN.7
      INCLUDE 'const.h'                                                    ELDEN.8
      INCLUDE 'index.h'                                                    ELDEN.9
      INCLUDE 'buffe.h'                                                    ELDEN.10
      INCLUDE 'rates.h'                                                    ELDEN.11
      COMMON/MASS/RMN4S,RMN2D,RMNO,BRN2D,CEE                               ELDEN.12
C     ****                                                                 ELDEN.13
C     ****     S12 = N*MBAR =PO*EXP(-Z)*MBAR/(K*T)                         ELDEN.14
C     ****                                                                 ELDEN.15
      NTK=NJ+NT-1                                                          ELDEN.16
      NMSK=NJ+NMS-1                                                        ELDEN.17
      DO K=1,KMAX                                                          ELDEN.18
       NTK=NTK+1                                                           ELDEN.19
       NMSK=NMSK+1                                                         ELDEN.20
       DO I=1,LEN1                                                         ELDEN.21
        S12(I,K)=C(81)*EXPS(K)*.5*(F(I,NMSK)+F(I,NMSK+1))/(C(84)*          ELDEN.22
     1           F(I,NTK))                                                 ELDEN.23
       ENDDO                                                               ELDEN.24
      ENDDO                                                                ELDEN.25
C     ****                                                                 ELDEN.26
C     ****     CALCULATE N(N+)                                             ELDEN.27
C     ****                                                                 ELDEN.28
      NNPK=NNP                                                             ELDEN.29
      NQNPK=NQNP                                                           ELDEN.30
      NOPK=NJ+NOP                                                          ELDEN.31
      NPN2DK=NJ+NPN2D                                                      ELDEN.32
      NPS1K=NJ+NPS                                                         ELDEN.33
      NPS2K=NJ+NPS2                                                        ELDEN.34
      DO I=1,LEN2                                                          ELDEN.35
       F(I,NNPK)=(.5*(F(I,NQNPK)+F(I,NQNPK+1))+RK10(I,1)*F(I,NOPK)*        ELDEN.36
     1           F(I,NPN2DK)*S12(I,1)/RMN2D)/(S12(I,1)*((RK6(I,1)+         ELDEN.37
     1           RK7(I,1))*F(I,NPS1K)/RMASS(1)+RK8(I,1)*F(I,NPS2K)/        ELDEN.38
     2           RMASS(2)))                                                ELDEN.39
      ENDDO                                                                ELDEN.40
C     ****                                                                 ELDEN.41
C     ****     CALCULATE A, B, C, D, E, (F+G) AND H FOR QUARTIC            ELDEN.42
C     ****                                                                 ELDEN.43
      NQNOPK=NQNOP                                                         ELDEN.44
      NQO2PK=NQO2P                                                         ELDEN.45
      NQN2PK=NQN2P                                                         ELDEN.46
      NOPK=NJ+NOP                                                          ELDEN.47
      NNPK=NNP                                                             ELDEN.48
      NPS1K=NJ+NPS                                                         ELDEN.49
      NPS2K=NJ+NPS2                                                        ELDEN.50
      NPNOK=NJ+NPNO                                                        ELDEN.51
      NPN4SK=NJ+NPN4S                                                      ELDEN.52
      NNO2K=NNO2                                                           ELDEN.53
      DO I=1,LEN2                                                          ELDEN.54
C      ****                                                                ELDEN.55
C      ****     S10 = A = QI(NO+)+K2*N(O+)*N(N2)+K7*N(N+)*N(02)+B9*N(NO)   ELDEN.56
C      ****                                                                ELDEN.57
       S10(I,1)=.5*(F(I,NQNOPK)+F(I,NQNOPK+1))+S12(I,1)*(RK2(I,1)*         ELDEN.58
     1          F(I,NOPK)*(1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3)+RK7(I,1)*    ELDEN.59
     1          F(I,NNPK)*F(I,NPS1K)/RMASS(1)+.5*(BETA9(I,1)+              ELDEN.60
     2          BETA9(I+LEN1,1))*F(I,NPNOK)/RMNO)                          ELDEN.61
C      ****                                                                ELDEN.62
C      ****     S9 = B = QI(O2+)+K1*N(O+)*N(O2)+K6*N(N+)*N(02)             ELDEN.63
C      ****                                                                ELDEN.64
       S9(I,1)=.5*(F(I,NQO2PK)+F(I,NQO2PK+1))+S12(I,1)*(RK1(I,1,1)*        ELDEN.65
     1         F(I,NOPK)+RK6(I,1)*F(I,NNPK))*F(I,NPS1K)/RMASS(1)+          ELDEN.66
     2         RK26(I,1)*XIOP2D(I,1)*F(I,NPS1K)/RMASS(1)                   ELDEN.67
C      ****                                                                ELDEN.68
C      ****     S8 = C = K4*N(N4S)+K5*N(NO)                                ELDEN.69
C      ****                                                                ELDEN.70
       S8(I,1)=S12(I,1)*(RK4(I,1)*F(I,NPN4SK)/RMN4S+RK5(I,1)*F(I,NPNOK)/   ELDEN.71
     1         RMNO)                                                       ELDEN.72
C      ****                                                                ELDEN.73
C      ****     S7 = D = QI(N2+)                                           ELDEN.74
C      ****                                                                ELDEN.75
       S7(I,1)=.5*(F(I,NQN2PK)+F(I,NQN2PK+1))+(RK16(I,1)*XIOP2P(I,1)       ELDEN.76
     1         +RK23(I,1)*XIOP2D(I,1))*(1.-F(I,NPS1K)-F(I,NPS2K))          ELDEN.77
     2         /RMASS(3)                                                   ELDEN.78
C      ****                                                                ELDEN.79
C      ****     S6 = E =K3*N(O)+K9*N(O2)                                   ELDEN.80
C      ****                                                                ELDEN.81
       S6(I,1)=S12(I,1)*(RK3(I,1)*F(I,NPS2K)/RMASS(2)+RK9(I,1)*            ELDEN.82
     1         F(I,NPS1K)/RMASS(1))                                        ELDEN.83
C      ****                                                                ELDEN.84
C      ****     S5 = F+G = N(O+)+N(N+)                                     ELDEN.85
C      ****                                                                ELDEN.86
       S5(I,1)=F(I,NOPK)+F(I,NNPK)                                         ELDEN.87
C      ****                                                                ELDEN.88
C      ****     S4 = H = K9*N(02)                                          ELDEN.89
C      ****                                                                ELDEN.90
       S4(I,1)=S12(I,1)*RK9(I,1)*F(I,NPS1K)/RMASS(1)                       ELDEN.91
C      ****                                                                ELDEN.92
C      ****     CALCULATE QUARTIC COEFFICIENTS                             ELDEN.93
C      ****                                                                ELDEN.94
C      ****     S15 = A0                                                   ELDEN.95
C      ****                                                                ELDEN.96
       S15(I,1)=-S6(I,1)*S8(I,1)*(S10(I,1)+S9(I,1)+S7(I,1))                ELDEN.97
C      ****                                                                ELDEN.98
C      ****     S14 = A1/4                                                 ELDEN.99
C      ****                                                                ELDEN.100
       S14(I,1)=-(RA1(I,1)*(S6(I,1)*(S8(I,1)*S5(I,1)+S9(I,1))+S7(I,1)*     ELDEN.101
     1          (S8(I,1)+S4(I,1)))+RA2(I,1)*(S6(I,1)*(S10(I,1)+            ELDEN.102
     2          S7(I,1))-S4(I,1)*S7(I,1))+RA3(I,1)*S8(I,1)*(S10(I,1)+      ELDEN.103
     3          S9(I,1)))/4.                                               ELDEN.104
C      ****                                                                ELDEN.105
C      ****     S13 = A2/6                                                 ELDEN.106
C      ****                                                                ELDEN.107
       S13(I,1)=(RA1(I,1)*(S6(I,1)*S8(I,1)-(RA2(I,1)*S6(I,1)+RA3(I,1)*     ELDEN.108
     1          S8(I,1))*S5(I,1)-RA2(I,1)*S7(I,1)-RA3(I,1)*S9(I,1))-       ELDEN.109
     2          RA2(I,1)*RA3(I,1)*S10(I,1))/6.                             ELDEN.110
C      ****                                                                ELDEN.111
C      ****     S12 = A3/4                                                 ELDEN.112
C      ****                                                                ELDEN.113
       S12(I,1)=(RA1(I,1)*(RA2(I,1)*S6(I,1)+RA3(I,1)*S8(I,1)-RA2(I,1)*     ELDEN.114
     1          RA3(I,1)*S5(I,1)))/4.                                      ELDEN.115
C      ****                                                                ELDEN.116
C      ****     S11 = A4                                                   ELDEN.117
C      ****                                                                ELDEN.118
       S11(I,1)=RA1(I,1)*RA2(I,1)*RA3(I,1)                                 ELDEN.119
      ENDDO                                                                ELDEN.120
C     ****                                                                 ELDEN.121
C     ****     SOLVE QUARTIC    ( S5 =  N(E) )                             ELDEN.122
C     ****                                                                 ELDEN.123
      CALL VQUART(S15,S5,S3,S2,S1,LEN3,1,LEN2)                             ELDEN.124
C     ****                                                                 ELDEN.125
C     ****     ENSURE NON NEGATIVE N(E)                                    ELDEN.126
C     ****                                                                 ELDEN.127
C     ****     CALCULATE N(N2+), N(02+) AND N(NO+)                         ELDEN.128
C     ****                                                                 ELDEN.129
      NN2PK=NN2P                                                           ELDEN.130
      NO2PK=NJNP+NO2P                                                      ELDEN.131
      NNOPK=NNOP                                                           ELDEN.132
      DO I=1,LEN2                                                          ELDEN.133
       IF(S5(I,1).LE.100.)S5(I,1)=100.                                     ELDEN.134
       F(I,NN2PK)=S7(I,1)/(S6(I,1)+RA3(I,1)*S5(I,1))                       ELDEN.135
       F(I,NO2PK)=(S9(I,1)+S4(I,1)*S7(I,1)/(S6(I,1)+RA3(I,1)*S5(I,1)))/    ELDEN.136
     1            (S8(I,1)+RA2(I,1)*S5(I,1))                               ELDEN.137
       F(I,NNOPK)=(S10(I,1)+S7(I,1)*(S6(I,1)-S4(I,1))/(S6(I,1)+RA3(I,1)*   ELDEN.138
     1            S5(I,1))+S8(I,1)*(S9(I,1)+S4(I,1)*S7(I,1)/(S6(I,1)+      ELDEN.139
     2            RA3(I,1)*S5(I,1)))/(S8(I,1)+RA2(I,1)*S5(I,1)))/          ELDEN.140
     3            (RA1(I,1)*S5(I,1))                                       ELDEN.141
      ENDDO                                                                ELDEN.142
C     ****                                                                 ELDEN.143
C     ****     PLACE N(E) IN SLOT IN F-ARRAY                               ELDEN.144
C     ****                                                                 ELDEN.145
      NEK=NJNP+NE                                                          ELDEN.146
      DO I=1,LEN2-LEN1                                                     ELDEN.147
       F(I,NEK+1)=DSQRT(S5(I,1)*S5(I,2))                                   ELDEN.148
      ENDDO                                                                ELDEN.149
      DO I=1,LEN1                                                          ELDEN.150
       F(I,NEK)=DSQRT(S5(I,1)**3/S5(I,2))                                  ELDEN.151
       F(I,NEK+KMAX)=DSQRT(S5(I,KMAX)**3/S5(I,KMAXM1))                     ELDEN.152
      ENDDO                                                                ELDEN.153
      RETURN                                                               ELDEN.154
      END                                                                  ELDEN.155
C                                                                          ELDEN.156
*DK FLIP                                                                    FLIP.1
      SUBROUTINE FLIP                                                       FLIP.2
C     ****                                                                  FILP.3
C     ****                   FLIPS LCM CIRCULAR BUFFER INDICES              FLIP.4
C     ****                                                                  FILP.5
      INCLUDE 'param.h'                                                     FLIP.6
      INCLUDE 'buffe.h'                                                     FLIP.7
      DO M=1,MODULO                                                         FLIP.8
       NJTMP(M)=NJTMP(M+1)                                                  FLIP.9
      ENDDO                                                                 FLIP.10
      NJTMP(MODULO+1)=NJTMP(1)                                              FLIP.11
      RETURN                                                                FLIP.12
      END                                                                   FLIP.13
C                                                                           FLIP.14
*DK GLP                                                                      GLP.1
      SUBROUTINE GLP(ZL,ZP)                                                  GLP.2
      INCLUDE 'param.h'                                                      GLP.3
      INCLUDE 'const.h'                                                      GLP.4
      INCLUDE 'buffe.h'                                                      GLP.5
      INCLUDE 'vscrw.h'                                                      GLP.6
      INCLUDE 'index.h'                                                      GLP.7
      INCLUDE 'phycs.h'                                                      GLP.8
      INCLUDE 'start.h'                                                      GLP.9
      DIMENSION ZL(ZIMXP,ZKMXP),ZP(ZIMXP,ZKMXP)                              GLP.10
      COMPLEX*16 EXPT                                                        GLP.11
      DATA WT/0.225/                                                         GLP.12
C     ****                                                                   GLP.13
C     ****     S6=TN+WT*(TNM-2.*TN+TNP)=TBAR                                 GLP.14
C     ****                                                                   GLP.15
      NTK=NJ+NT                                                              GLP.16
      NTNMK=NJ+NTNM                                                          GLP.17
      NTNPK=NJNP+NT                                                          GLP.18
      DO I=1,LEN2                                                            GLP.19
       S6(I,1)=(F(I,NTNMK)+F(I,NTNPK)-2.*F(I,NTK))*WT+F(I,NTK)               GLP.20
      ENDDO                                                                  GLP.21
C     ****                                                                   GLP.22
C     ****     S7(K)=(MS(K)+MS(K+1))*.5=MBAR                                 GLP.23
C     ****                                                                   GLP.24
      NMSK=NJ+NMS                                                            GLP.25
      DO I=1,LEN2                                                            GLP.26
       S7(I,1)=(F(I,NMSK)+F(I,NMSK+1))*.5                                    GLP.27
      ENDDO                                                                  GLP.28
C     ****                                                                   GLP.29
C     ****     S7=S6/S7=(TBAR+T0)/M                                          GLP.30
C     ****     S7=(DS*R/G)*S7                                                GLP.31
C     ****     STORE NZ TEMPORARILY                                          GLP.32
C     ****                                                                   GLP.33
      DO I=1,LEN2                                                            GLP.34
       S7(I,1)=C(3)*S6(I,1)/(S7(I,1)*C(65))                                  GLP.35
      ENDDO                                                                  GLP.36
      NZK=NJ+NZ                                                              GLP.37
      DO I=1,LEN3                                                            GLP.38
       S6(I,1)=F(I,NZK)                                                      GLP.39
      ENDDO                                                                  GLP.40
C     ****                                                                   GLP.41
C     ****     Z(1)=ZB                                                       GLP.42
C     ***                                                                    GLP.43
      EXPT=CDEXP(CI*C(23)*C(4)*DBLE(ITER))                                   GLP.44
      DO I=1,LEN1                                                            GLP.45
       F(I,NZK)=DREAL(ZB(J)*BND(I)*EXPT)                                     GLP.46
      ENDDO                                                                  GLP.47
C     ****                                                                   GLP.48
C     ****     Z(1) = ZB+ZB2                                                 GLP.49
C     ****                                                                   GLP.50
      EXPT=CDEXP(CI*.5*C(23)*C(4)*DBLE(ITER))                                GLP.51
      DO I=1,LEN1                                                            GLP.52
       F(I,NZK)=F(I,NZK)+DREAL(ZB2(J)*BND2(I)*EXPT)                          GLP.53
      ENDDO                                                                  GLP.54
C     *****     Z(1) = ZB+ZB2+ZBA                                            GLP.55
      EXPT=(1.d0,0.d0)                                                       GLP.56
      DO I=1,LEN1                                                            GLP.57
       F(I,NZK)=F(I,NZK)+DREAL(ZBA(J)*BNDA(I)*EXPT)                          GLP.58
      ENDDO                                                                  GLP.59
C     ****                                                                   GLP.60
C     ****     Z(K+1)=S7(K)+Z(K)                                             GLP.61
C     ****                                                                   GLP.62
      DO K=1,KMAX                                                            GLP.63
       DO I=1,LEN1	                                                     GLP.64
        F(I,NZK+1)=S7(I,K)+F(I,NZK)                                          GLP.65
       ENDDO                                                                 GLP.66
       NZK=NZK+1                                                             GLP.67
      ENDDO                                                                  GLP.68
C     ****                                                                   GLP.69
C     ****     INSERT PERIODIC POINTS                                        GLP.70
C     ****                                                                   GLP.71
      NZK=NJ+NZ-1                                                            GLP.72
      DO K=1,KMAXP1                                                          GLP.73
       NZK=NZK+1                                                             GLP.74
       DO I=1,2                                                              GLP.75
        F(I,NZK)=F(I+IMAX,NZK)                                               GLP.76
        F(I+IMAXP2,NZK)=F(I+2,NZK)                                           GLP.77
       ENDDO                                                                 GLP.78
      ENDDO                                                                  GLP.79
      CALL DLDP(NZ,ZL,ZP,LEN3-4)                                             GLP.80
C     ****                                                                   GLP.81
C     ****     RESTORE NZ                                                    GLP.82
C     ****                                                                   GLP.83
      NZK=NJ+NZ                                                              GLP.84
      DO I=1,LEN3                                                            GLP.85
       F(I,NZK)=S6(I,1)                                                      GLP.86
      ENDDO                                                                  GLP.87
      DO K=1,KMAX                                                            GLP.88
       DO I=3,LEN1-2                                                         GLP.89
        ZL(I,K)=(ZL(I,K)+ZL(I,K+1))*.5*C(54)*RACS                            GLP.90
        ZP(I,K)=(ZP(I,K)+ZP(I,K+1))*.5*C(54)*C(52)                           GLP.91
       ENDDO                                                                 GLP.92
      ENDDO                                                                  GLP.93
C     ****                                                                   GLP.81
C     ****     PERIODIC POINTS FOR ZL AND ZP                                 GLP.82
C     ****                                                                   GLP.83
      DO I=1,2                                                               GLP.84
       DO K=1,KMAX                                                           GLP.85
        ZL(I,K)=ZL(I+IMAX,K)                                                 GLP.86
        ZL(I+IMAXP2,K)=ZL(I+2,K)                                             GLP.87
        ZP(I,K)=ZP(I+IMAX,K)                                                 GLP.88
        ZP(I+IMAXP2,K)=ZP(I+2,K)                                             GLP.89
       ENDDO                                                                 GLP.90
      ENDDO                                                                  GLP.91
      RETURN                                                                 GLP.92
      END                                                                    GLP.93
C                                                                            GLP.94
*DK HDIF                                                                    HDIF.1
      SUBROUTINE HDIF                                                       HDIF.2
      INCLUDE 'param.h'                                                     HDIF.3
      INCLUDE 'vscrw.h'                                                     HDIF.4
      INCLUDE 'buffe.h'                                                     HDIF.5
      INCLUDE 'const.h'                                                     HDIF.6
      INCLUDE 'index.h'                                                     HDIF.7
      INCLUDE 'phycs.h'                                                     HDIF.8
C     ****                                                                  HDIF.9
C     ****                   SAVE KMH VALUES OF LINE J IN S2                HDIF.10
C     ****                                                                  HDIF.11
      NKMHK=NKMH                                                            HDIF.12
      DO I=1,LEN2                                                           HDIF.13
       S2(I,1)=F(I,NKMHK)                                                   HDIF.14
      ENDDO                                                                 HDIF.15
C     ****                                                                  HDIF.16
C     ****     SAVE RH(J)=M/(T+T0) IN S4                                    HDIF.17
C     ****                                                                  HDIF.18
      NRHK=NRH                                                              HDIF.19
      DO I=1,LEN2                                                           HDIF.20
       S4(I,1)=F(I,NRHK)                                                    HDIF.21
      ENDDO                                                                 HDIF.22
C     ****                                                                  HDIF.23
C     ****                   READ U,V FOR J+1,J+2,AT N-1                    HDIF.24
C     ****                                                                  HDIF.25
      NUJP2=NJP2+NUNM                                                       HDIF.26
      NUJP1=NJP1+NUNM                                                       HDIF.27
      NVJP2=NJP2+NVNM                                                       HDIF.28
      NVJP1=NJP1+NVNM                                                       HDIF.29
C     ****                                                                  HDIF.30
C     ****                   CALC KMH = 2*K0*K0*SQRT(DS*DS+DT*DT)           HDIF.31
C     ****                                                                  HDIF.32
      ABCSJ=DABS(CS(J+1))                                                   HDIF.33
      ABCSJP=DABS(CS(J+2))                                                  HDIF.34
      CON1=C(52)*.5/C(1)                                                    HDIF.35
      CON2=C(52)/(C(2)*(ABCSJ+ABCSJP))                                      HDIF.36
      CON3=2.*C(109)*C(109)                                                 HDIF.37
      LONGP3=LEN2-1                                                         HDIF.39
      DO I=1,LONGP3                                                         HDIF.40
       DT=CON1*((F(I+1,NUJP2)-F(I,NUJP2))/CS(J+2)+                          HDIF.41
     1    (F(I+1,NUJP1)-F(I,NUJP1))/CS(J+1))-                               HDIF.42
     2    CON2*((F(I+1,NVJP2)+F(I,NVJP2))*ABCSJP-                           HDIF.43
     3    (F(I+1,NVJP1)+F(I,NVJP1))*ABCSJ)                                  HDIF.44
       DS=CON1*((F(I+1,NVJP2)-F(I,NVJP2))/CS(J+2)+                          HDIF.45
     1    (F(I+1,NVJP1)-F(I,NVJP1))/CS(J+1))+                               HDIF.46
     2    CON2*((F(I+1,NUJP2)+F(I,NUJP2))*ABCSJP-                           HDIF.47
     3    (F(I+1,NUJP1)+F(I,NUJP1))*ABCSJ)                                  HDIF.48
       F(I,NKMHK)=CON3*DSQRT(DS*DS+DT*DT)                                   HDIF.49
      ENDDO                                                                 HDIF.50
C     ****                                                                  HDIF.51
C     ****     CALCULATE RH*AVG(KMH) ON LINE J+1                            HDIF.52
C     ****                                                                  HDIF.53
C     ****     RH=M/(T+T0)                                                  HDIF.54
C     ****                                                                  HDIF.55
      NMSJPK=NJP1+NMS                                                       HDIF.56
      NTJP1K=NJP1+NTNM                                                      HDIF.57
      DO I=1,LEN2                                                           HDIF.58
       F(I,NRHK)=0.5*(F(I,NMSJPK)+F(I,NMSJPK+1))/F(I,NTJP1K)                HDIF.59
      ENDDO                                                                 HDIF.60
C     ****                                                                  HDIF.61
C     ****                   FOR FIRST CALL FOR EACH ITERATION, ONLY        HDIF.62
C     ****                   NEED TO COMPUTE KMH                            HDIF.63
C     ****                                                                  HDIF.64
      IF(J.LE.-2) RETURN                                                    HDIF.65
C     ****                                                                  HDIF.66
C     ****                   CALC AVG KMH VALUE AT EACH GRID PT ON J+1      HDIF.67
C     ****                                                                  HDIF.68
      DO K=1,KMAX                                                           HDIF.69
       DO I=2,LEN1                                                          HDIF.70
        S1(I,K)=0.25*(S2(I-1,K)+S2(I,K)+F(I-1,NKMHK)+F(I,NKMHK))            HDIF.71
       ENDDO                                                                HDIF.72	
       NKMHK=NKMHK+1                                                        HDIF.73
      ENDDO                                                                 HDIF.74
      DO I=1,LEN2                                                           HDIF.75
       S2(I,1)=S1(I,1)*F(I,NRHK)                                            HDIF.76
      ENDDO                                                                 HDIF.77
C     ****                                                                  HDIF.78
C     ****                   CALC RHO*KMH*(L*L(D*D)(PSI)) AT J+1 AND N-1    HDIF.79
C     ****                        FOR PSI = U                               HDIF.80
C     ****                                                                  HDIF.81
      NUNMP2=NJP2+NUNM                                                      HDIF.82
      NUNMP1=NJP1+NUNM                                                      HDIF.83
      NUNMK=NJ+NUNM                                                         HDIF.84
      NKLDUK=NJP1+NKLDU                                                     HDIF.85
      CALL LSQDSQ(J+1,F(1,NUNMP2),F(1,NUNMP1),F(1,NUNMK),S1)                HDIF.86
      DO K=1,KMAX                                                           HDIF.87
       DO I=2,LEN1                                                          HDIF.88
        F(I,NKLDUK)=S1(I-1,K)*S2(I,K)                                       HDIF.89
       ENDDO                                                                HDIF.90
       F(1,NKLDUK)=F(73,NKLDUK)                                             HDIF.91
       F(76,NKLDUK)=F(4,NKLDUK)                                             HDIF.92
       NKLDUK=NKLDUK+1                                                      HDIF.93
      ENDDO                                                                 HDIF.94
C     ****                                                                  HDIF.95
C     ****                        FOR PSI = V                               HDIF.96
C     ****                                                                  HDIF.97
      NVNMP2=NJP2+NVNM                                                      HDIF.98
      NVNMP1=NJP1+NVNM                                                      HDIF.99
      NVNMK=NJ+NVNM                                                         HDIF.100
      NKLDVK=NJP1+NKLDV                                                     HDIF.101
      CALL LSQDSQ(J+1,F(1,NVNMP2),F(1,NVNMP1),F(1,NVNMK),S1)                HDIF.102
      DO K=1,KMAX                                                           HDIF.103
       DO I=2,LEN1                                                          HDIF.104
        F(I,NKLDVK)=S1(I-1,K)*S2(I,K)                                       HDIF.105
       ENDDO                                                                HDIF.106
       F(1,NKLDVK)=F(73,NKLDVK)                                             HDIF.107
       F(76,NKLDVK)=F(4,NKLDVK)                                             HDIF.108
       NKLDVK=NKLDVK+1                                                      HDIF.109
      ENDDO                                                                 HDIF.110
C     ****                                                                  HDIF.111
C     ****     FOR PSI=T                                                    HDIF.112
C     ****                                                                  HDIF.113
      NTNMP2=NJP2+NTNM                                                      HDIF.114
      NTNMP1=NJP1+NTNM                                                      HDIF.115
      NTNMK=NJ+NTNM                                                         HDIF.116
      NKLDTK=NJP1+NKLDT                                                     HDIF.117
      CALL LSQDSQ(J+1,F(1,NTNMP2),F(1,NTNMP1),F(1,NTNMK),S1)                HDIF.118
      DO K=1,KMAX                                                           HDIF.119
       DO I=2,LEN1                                                          HDIF.120
        F(I,NKLDTK)=S1(I-1,K)*S2(I,K)                                       HDIF.121
       ENDDO                                                                HDIF.122
       F(1,NKLDTK)=F(73,NKLDTK)                                             HDIF.123
       F(76,NKLDTK)=F(4,NKLDTK)                                             HDIF.124
       NKLDTK=NKLDTK+1                                                      HDIF.125
      ENDDO                                                                 HDIF.126
C     ****                                                                  HDIF.127
C     ****     FOR PSI=PS1                                                  HDIF.128
C     ****                                                                  HDIF.129
      DO L=1,2                                                              HDIF.130
       NPSK=NPSNM+(L-1)*KMAXP1                                              HDIF.131
       NPNMP2=NJP2+NPSK                                                     HDIF.132
       NPNMP1=NJP1+NPSK                                                     HDIF.133
       NPNMK=NJ+NPSK                                                        HDIF.134
       NKLDPK=NJP1+NKLDPS+(L-1)*KMAX                                        HDIF.135
       CALL LSQDSQ(J+1,F(1,NPNMP2),F(1,NPNMP1),F(1,NPNMK),S1)               HDIF.136
       DO K=1,KMAX                                                          HDIF.137
        DO I=2,LEN1                                                         HDIF.138
         F(I,NKLDPK)=S1(I-1,K)*S2(I,K)                                      HDIF.139
        ENDDO                                                               HDIF.140
        F(1,NKLDPK)=F(73,NKLDPK)                                            HDIF.141
        F(76,NKLDPK)=F(4,NKLDPK)                                            HDIF.142
        NKLDPK=NKLDPK+1                                                     HDIF.143
       ENDDO                                                                HDIF.144
      ENDDO                                                                 HDIF.145
C     ****                                                                  HDIF.146
C     ****     FOR J.GE.1 CALCULATE FLH,FPH AND QDH                         HDIF.147
C     ****                                                                  HDIF.148
      IF(J.LE.0) RETURN                                                     HDIF.149
C     ****                                                                  HDIF.150
C     ****     S2=-(T+T0)/M=-1./S4                                          HDIF.151
C     ****                                                                  HDIF.152
      DO I=1,LEN2                                                           HDIF.153
       S2(I,1)=-1./S4(I,1)                                                  HDIF.154
      ENDDO                                                                 HDIF.155
C     ****                                                                  HDIF.156
C     ****                   CALC FLH                                       HDIF.157
C     ****                                                                  HDIF.158
      NKLDPK=NJP1+NKLDU                                                     HDIF.159
      NKLDK=NJ+NKLDU                                                        HDIF.160
      NKLDMK=NJM1+NKLDU                                                     HDIF.161
      NFLHK=NFLH                                                            HDIF.162
      CALL LSQDSQ(J,F(1,NKLDPK),F(1,NKLDK),F(1,NKLDMK),S1)                  HDIF.163
      DO K=1,KMAX                                                           HDIF.164
       DO I=2,LEN1                                                          HDIF.165
        F(I,NFLHK)=S1(I-1,K)*S2(I,K)                                        HDIF.166
       ENDDO                                                                HDIF.167
       F(1,NFLHK)=F(73,NFLHK)                                               HDIF.168
       F(2,NFLHK)=F(74,NFLHK)                                               HDIF.169
       F(75,NFLHK)=F(3,NFLHK)                                               HDIF.170
       F(76,NFLHK)=F(4,NFLHK)                                               HDIF.171
       NFLHK=NFLHK+1                                                        HDIF.172
      ENDDO                                                                 HDIF.173
C     ****                                                                  HDIF.174
C     ****                   CALC FPH                                       HDIF.175
C     ****                                                                  HDIF.176
      NKLDPK=NJP1+NKLDV                                                     HDIF.177
      NKLDK=NJ+NKLDV                                                        HDIF.178
      NKLDMK=NJM1+NKLDV                                                     HDIF.179
      NFPHK=NFPH                                                            HDIF.180
      CALL LSQDSQ(J,F(1,NKLDPK),F(1,NKLDK),F(1,NKLDMK),S1)                  HDIF.181
      DO K=1,KMAX                                                           HDIF.182
       DO I=2,LEN1                                                          HDIF.183
        F(I,NFPHK)=S1(I-1,K)*S2(I,K)                                        HDIF.184
       ENDDO                                                                HDIF.185
       F(1,NFPHK)=F(73,NFPHK)                                               HDIF.186
       F(2,NFPHK)=F(74,NFPHK)                                               HDIF.187
       F(75,NFPHK)=F(3,NFPHK)                                               HDIF.188
       F(76,NFPHK)=F(4,NFPHK)                                               HDIF.189
       NFPHK=NFPHK+1                                                        HDIF.190
      ENDDO                                                                 HDIF.191
C     ****                                                                  HDIF.192
C     ****                   CALC QDH                                       HDIF.193
C     ****                                                                  HDIF.194
      NKLDPK=NJP1+NKLDT                                                     HDIF.195
      NKLDK=NJ+NKLDT                                                        HDIF.196
      NKLDMK=NJM1+NKLDT                                                     HDIF.197
      NQDHK=NQDH                                                            HDIF.198
      NCPK=NCP                                                              HDIF.199
      CALL LSQDSQ(J,F(1,NKLDPK),F(1,NKLDK),F(1,NKLDMK),S1)                  HDIF.200
      DO K=1,KMAX                                                           HDIF.201
       DO I=2,LEN1                                                          HDIF.202
        F(I,NQDHK)=S1(I-1,K)*S2(I,K)*(F(I,NCPK)+F(I,NCPK+1))*.5             HDIF.203
       ENDDO                                                                HDIF.204
       F(1,NQDHK)=F(73,NQDHK)                                               HDIF.205
       F(2,NQDHK)=F(74,NQDHK)                                               HDIF.206
       F(75,NQDHK)=F(3,NQDHK)                                               HDIF.207
       F(76,NQDHK)=F(4,NQDHK)	                                            HDIF.208
       NCPK=NCPK+1                                                          HDIF.209
       NQDHK=NQDHK+1                                                        HDIF.210
      ENDDO                                                                 HDIF.211
C     ****                                                                  HDIF.212
C     ****     CALCULATE PSDH                                               HDIF.113
C     ****                                                                  HDIF.214
      DO L=1,2                                                              HDIF.215
       NKLK=NKLDPS+(L-1)*KMAX                                               HDIF.216
       NKLDPK=NJP1+NKLK                                                     HDIF.217
       NKLDK=NJ+NKLK                                                        HDIF.218
       NKLDMK=NJM1+NKLK                                                     HDIF.219
       NPSDHK=NPSDH+(L-1)*KMAX                                              HDIF.220
       CALL LSQDSQ(J,F(1,NKLDPK),F(1,NKLDK),F(1,NKLDMK),S1)                 HDIF.221
       DO K=1,KMAX                                                          HDIF.222
        DO I=2,LEN1                                                         HDIF.223
         F(I,NPSDHK)=S1(I-1,K)*S2(I,K)                                      HDIF.224
        ENDDO                                                               HDIF.225
        NPSDHK=NPSDHK+1                                                     HDIF.226
       ENDDO                                                                HDIF.227
C      ****                                                                 HDIF.228
C      ****     INSERT PERIODIC POINTS                                      HDIF.229
C      ****                                                                 HDIF.230
       NPSDHK=NPSDH+(L-1)*KMAX-1                                            HDIF.231
       DO I=1,2                                                             HDIF.232
        DO K=1,KMAX                                                         HDIF.233
         F(I,NPSDHK+K)=F(I+IMAX,NPSDHK+K)                                   HDIF.234
         F(I+IMAXP2,NPSDHK+K)=F(I+2,NPSDHK+K)                               HDIF.235
        ENDDO                                                               HDIF.236
       ENDDO                                                                HDIF.237
      ENDDO                                                                 HDIF.238
      RETURN                                                                HDIF.239
      END                                                                   HDIF.240
C                                                                           HDIF.241
*DK LSQDSQ                                                                LSQDSQ.1
      SUBROUTINE LSQDSQ(JJ,PSIJP,PSIJ,PSIJM,S)                            LSQDSQ.2
C     ****                                                                LSQDSQ.3
C     ****                   SUBROUTINE TO CALCULATE L**2DEL**2(PSI)      LSQDSQ.4
C     ****                        JJ IS THE CURRENT LATITUDE LINE,        LSQDSQ.5
C     ****                        PSIJP,PSIJ,PSIJM ARE THE 3 APPROPRIATE  LSQDSQ.6
C     ****                        LATITUDE LINES J+1,J,J-1,  AND          LSQDSQ.7
C     ****                        S IS THE ARRAY FOR THE RESULT.          LSQDSQ.8
C     ****                                                                LSQDSQ.9
      INCLUDE 'param.h'                                                   LSQDSQ.10
      INCLUDE 'const.h'                                                   LSQDSQ.11
      INCLUDE 'index.h'                                                   LSQDSQ.12
      DIMENSION PSIJP(ZIMXP,ZKMX),PSIJ(ZIMXP,ZKMX),PSIJM(ZIMXP,ZKMX),     LSQDSQ.13
     1          S(ZIMXP,ZKMX),DPSI(ZIMXP,ZKMX),DPSIP(ZIMXP,ZKMX),         LSQDSQ.14
     2          DPSIM(ZIMXP,ZKMX)                                         LSQDSQ.15
C     ****                                                                LSQDSQ.16
C     ****                   LONG AND LAT LENGTH FUNCTIONS                LSQDSQ.17
C     ****                   FLENL = A*ABS(COS(JJ))*PI/KUT(JJ)            LSQDSQ.18
C     ****                   FLENP = A*DPHI                               LSQDSQ.19
C     ****                                                                LSQDSQ.20
      FLENL=C(51)*DABS(CS(JJ))*C(1)                                       LSQDSQ.21
      FLENP=C(51)*C(2)                                                    LSQDSQ.22
      CON1=FLENL*FLENL/(C(51)*CS(JJ)*C(1))**2                             LSQDSQ.23
      CON2=FLENP*FLENP/((C(51)*C(2))**2*CS(JJ))                           LSQDSQ.24
C     ****                                                                LSQDSQ.25
C     ****                   S = L*L/(A*CS(JJ)*DLAMBDA)**2*(PSI(I+1) -    LSQDSQ.26
C     ****                       2*PSI(I) + PSI(I-1))                     LSQDSQ.27
C     ****                                                                LSQDSQ.28
      DO K=1,KMAX                                                         LSQDSQ.29
       DO I=1,IMAXP2                                                      LSQDSQ.30
        S(I,K)=(PSIJ(I+2,K)-2.*PSIJ(I+1,K)+PSIJ(I,K))*CON1                LSQDSQ.31
       ENDDO                                                              LSQDSQ.32
      ENDDO                                                               LSQDSQ.33
C     ****                                                                LSQDSQ.34
C     ****                   DPSIP=(PSI(J+1)-PSI(J))*.5*(CS(J+1)+CS(J))   LSQDSQ.35
C     ****                   DPSIM=(PSI(J)-PSI(J-1))*.5*(CS(J)+CS(J-1))   LSQDSQ.36
C     ****                   DPSI = (DPSIP-DPSIM)*(LP**2/                 LSQDSQ.37
C     ****                          (A*A*CS(J)*DPHI*2)                    LSQDSQ.38
C     ****                                                                LSQDSQ.39
      DO K=1,KMAX                                                         LSQDSQ.40
       DO I=2,LEN1                                                        LSQDSQ.41
        DPSIP(I,K)=(PSIJP(I,K)-PSIJ(I,K))*.5*(CS(JJ+1)+CS(JJ))            LSQDSQ.42
        DPSIM(I,K)=(PSIJ(I,K)-PSIJM(I,K))*.5*(CS(JJ)+CS(JJ-1))            LSQDSQ.43
        DPSI(I,K)=(DPSIP(I,K)-DPSIM(I,K))*CON2                            LSQDSQ.44
       ENDDO                                                              LSQDSQ.45
      ENDDO                                                               LSQDSQ.46
C     ****                                                                LSQDSQ.47
C     ****                   S = S + DPSI = (L**2)(D**2)PSI               LSQDSQ.48
C     ****                                                                LSQDSQ.49
      DO K=1,KMAX                                                         LSQDSQ.50
       DO I=1,IMAXP2                                                      LSQDSQ.51
        S(I,K)=s(I,K)+DPSI(I+1,K)                                         LSQDSQ.52
       ENDDO                                                              LSQDSQ.53
       S(75,K)=S(3,K)                                                     LSQDSQ.54
       S(76,K)=S(4,K)                                                     LSQDSQ.55
      ENDDO                                                               LSQDSQ.56
      RETURN                                                              LSQDSQ.57
      END                                                                 LSQDSQ.58
C                                                                         LSQDSQ.59
*DK MINOR                                                                  MINOR.1
      SUBROUTINE MINOR(NX,NXNM,RMX,PHIX,ALFAX,IBND,IBNDB)                  MINOR.2
C     ****                                                                 MINOR.3
C     ****     ADVANCES MINOR SPECIES BY ONE TIME STEP                     MINOR.4
C     ****     NX = INDEX OF MINOR SPECIES FOR TIME T(N)                   MINOR.5
C     ****     NXNM = INDEX OF MINOR SPECIES FOR TIME T(N-1)               MINOR.6
C     ****     RMX = MOLECULAR WEIGHT OF MINOR SPECIES                     MINOR.7
C     ****     PHIX = DIFFUSION VECTOR, PHI(X,N),N=1,3                     MINOR.8
C     ****     ALFAX = THERMAL DIFFUSION COEFFICIENT                       MINOR.9
C     ****                                                                 MINOR.10
C     ****     LOWER BOUNDARY                                              MINOR.11
C     ****     IF IBNDB = 0,                                               MINOR.12
C     ****        T1 = A, T2 = B, T3 = C DEFINE LOWER BOUNDARY CONDITION   MINOR.13
C     ****        WHERE       A*DPSX/DZ + B*PSX + C = 0.                   MINOR.14
C     ****     IF IBNDB = 1,                                               MINOR.15
C     ****        T3 = TOTAL UPWARD NUMBER FLUX OF X AT LOWER BOUNDARY     MINOR.16
C     ****     UPPER BOUNDARY                                              MINOR.17
C     ****     IF IBND =0,                                                 MINOR.18
C     ****        T4 = DIFFUSIVE UPWARD NUMBER FLUX OF X AT UPPER          MINOR.19
C     ****             BOUNDARY                                            MINOR.20
C     ****     IF IBND =1,                                                 MINOR.21
C     ****        T4 = TOTAL UPWARD NUMBER FLUX OF X AT UPPER              MINOR.22
C     ****             BOUNDARY                                            MINOR.23
C     ****     IF IBND =2,                                                 MINOR.24
C     ****        T4 = VALUE OF PSX AT UPPER BOUNDARY                      MINOR.25
C     ****                                                                 MINOR.26
C     ****     SOURCES                                                     MINOR.27
C     ****     S1 = SX/N(X), WHERE SX IS PORTION OF NUMBER DENSITY         MINOR.28
C     ****        SOURCE PROPORTIONAL TO N(X), THE MINOR SPECIES NUMBER    MINOR.29
C     ****        DENSITY     (LEVEL K+1/2)                                MINOR.30
C     ****     S2 = S0, PORTION OF NUMBER DENSITY SOURCE INDEPENDENT       MINOR.31
C     ****        OF N(X).    (LEVEL K+1/2)                                MINOR.32
C     ****                                                                 MINOR.33
      INCLUDE 'param.h'                                                    MINOR.34
      INCLUDE 'start.h'                                                    MINOR.35
      INCLUDE 'vscrw.h'                                                    MINOR.36
      INCLUDE 'const.h'                                                    MINOR.37
      INCLUDE 'index.h'                                                    MINOR.38
      INCLUDE 'buffe.h'                                                    MINOR.39
      INCLUDE 'phycs.h'                                                    MINOR.40
      INCLUDE 'cpbnd.h'                                                    MINOR.40
      DIMENSION KUTT(ZJMX)                                                 MINOR.41
      DATA KUTT/1,2,3,5,6,7,9,10,11,13,14,15,17,10*17,17,15,14,13,11,10,   MINOR.42
     1     9,7,6,5,3,2,1/                                                  MINOR.43
      DIMENSION PHIX(3),PHI(2,3)                                           MINOR.44
      DATA PHI/0.,0.673,1.35,0.,1.11,0.769/,TAU/1.86D+3/,T00/273./,        MINOR.45
C     ****                                                                 MINOR.46
C     ****     VALUE OF 'SMALL' FOR MINOR                                  MINOR.47
C     ****                                                                 MINOR.48
     1SMALL/1.D-12/                                                        MINOR.49
C     ****                                                                 MINOR.51
C     ****     S13 = HORIZONAL ADVECTION                                   MINOR.52
C     ****                                                                 MINOR.53
      CALL ADVEC(NX,S13)                                                   MINOR.54
C     ****                                                                 MINOR.55
C     ****     S14=SX/N(X)(K+1/2),  S15=S0(K+1/2)                          MINOR.56
C     ****                                                                 MINOR.57
      DO I=1,LEN2                                                          MINOR.58
       S15(I,1)=S2(I,1)                                                    MINOR.59
       S14(I,1)=S1(I,1)                                                    MINOR.60
      ENDDO                                                                MINOR.61
C     ****                                                                 MINOR.62
C     ****     T4 = PS1(-1/2), T5 = PS2(-1/2), T6 = MBAR(-1/2)             MINOR.63
C     ****                                                                 MINOR.64
      NPS1K=NJ+NPS                                                         MINOR.65
      NPS2K=NPS1K+KMAXP1                                                   MINOR.66
      DO I=1,LEN1                                                          MINOR.67
       T7(I)=T4(I)                                                         MINOR.68
       T4(I)=B(I,1,1)*F(I,NPS1K)+B(I,1,2)*F(I,NPS2K)+FB(I,1)               MINOR.69
       T5(I)=B(I,2,1)*F(I,NPS1K)+B(I,2,2)*F(I,NPS2K)+FB(I,2)               MINOR.70
       T6(I)=1./(T4(I)/RMASS(1)+T5(I)/RMASS(2)+(1.-T4(I)-T5(I))/           MINOR.71
     1       RMASS(3))                                                     MINOR.72
      ENDDO                                                                MINOR.73
C     ****                                                                 MINOR.74
C     ****     S12 = MBAR(K+1/2)                                           MINOR.75
C     ****                                                                 MINOR.76
      DO I=1,LEN3                                                          MINOR.77
       S12(I,1)=1./(F(I,NPS1K)/RMASS(1)+F(I,NPS2K)/RMASS(2)+               MINOR.78
     1          (1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3))                       MINOR.79
      ENDDO                                                                MINOR.80
C     ****                                                                 MINOR.81
C     ****     S11 = MBAR(K), S10 = DM/DZ(K), S9 = PS2(K),                 MINOR.82
C     ****     S8 = PS1(K), S7 = DPS2/DZ(K), S6 = DPS1/DZ(K)               MINOR.83
C     ****     LOWER BOUNDARY                                              MINOR.84
C     ****                                                                 MINOR.85
      DO I=1,LEN1                                                          MINOR.86
       S11(I,1)=.5*(T6(I)+S12(I,1))                                        MINOR.87
       S10(I,1)=(S12(I,1)-T6(I))/C(3)                                      MINOR.88
       S9(I,1)=.5*(T5(I)+F(I,NPS2K))                                       MINOR.89
       S8(I,1)=.5*(T4(I)+F(I,NPS1K))                                       MINOR.90
       S7(I,1)=(F(I,NPS2K)-T5(I))/C(3)                                     MINOR.91
       S6(I,1)=(F(I,NPS1K)-T4(I))/C(3)                                     MINOR.92
       T4(I)=T7(I)                                                         MINOR.93
      ENDDO                                                                MINOR.94
C     ****                                                                 MINOR.95
C     ****     LEVELS K=2,KMAXP1                                           MINOR.96
C     ****                                                                 MINOR.97
      DO I=LEN1+1,LEN3                                                     MINOR.98
       S11(I,1)=.5*(S12(I,1)+S12(I-LEN1,1))                                MINOR.99
       S10(I,1)=(S12(I,1)-S12(I-LEN1,1))/C(3)                              MINOR.100
       S9(I,1)=.5*(F(I,NPS2K)+F(I,NPS2K-1))                                MINOR.101
       S8(I,1)=.5*(F(I,NPS1K)+F(I,NPS1K-1))                                MINOR.102
       S7(I,1)=(F(I,NPS2K)-F(I,NPS2K-1))/C(3)                              MINOR.103
       S6(I,1)=(F(I,NPS1K)-F(I,NPS1K-1))/C(3)                              MINOR.104
      ENDDO                                                                MINOR.105
C     ****                                                                 MINOR.106
C     ****     S5=T(TOT,K)                                                 MINOR.107
C     ****     LOWER AND UPPER BOUNDARIES                                  MINOR.108
C     ****                                                                 MINOR.109
      NTK=NJ+NT+KMAX                                                       MINOR.110
      DO I=1,LEN1                                                          MINOR.111
       S5(I,1)=F(I,NTK)                                                    MINOR.112
       S5(I,KMAXP1)=F(I,NTK-1)                                             MINOR.113
      ENDDO                                                                MINOR.114
C     ****                                                                 MINOR.115
C     ****     LEVELS K=2,KMAX                                             MINOR.116
C     ****                                                                 MINOR.117
      NTK=NJ+NT                                                            MINOR.118
      DO K=2,KMAX                                                          MINOR.119
       NTK=NTK+1                                                           MINOR.120
       DO I=1,LEN1                                                         MINOR.121
        S5(I,K)=.5*(F(I,NTK)+F(I,NTK-1))                                   MINOR.122
       ENDDO                                                               MINOR.123
      ENDDO                                                                MINOR.124
C     ****                                                                 MINOR.125
C     ****     EVALUATE ALFA12, ALFA21, ALFAM1, ALFAM2                     MINOR.126
C     ****                                                                 MINOR.127
      ALFA12=PHI(1,2)-PHI(1,3)                                             MINOR.128
      ALFA21=PHI(2,1)-PHI(2,3)                                             MINOR.129
      ALFAX1=PHIX(1)-PHIX(3)                                               MINOR.130
      ALFAX2=PHIX(2)-PHIX(3)                                               MINOR.131
C     ****                                                                 MINOR.132
C     ****     S15=(S0*MX/NMBAR)(K+1/2)                                    MINOR.133
C     ****                                                                 MINOR.134
      NTK=NJ+NT-1                                                          MINOR.135
      DO K=1,KMAX                                                          MINOR.136
       NTK=NTK+1                                                           MINOR.137
       DO I=1,LEN1                                                         MINOR.138
        S15(I,K)=S15(I,K)*RMX*C(84)*F(I,NTK)/(C(81)*EXPS(K)*S12(I,K))      MINOR.139
       ENDDO                                                               MINOR.140
      ENDDO                                                                MINOR.142
C     ****                                                                 MINOR.142
C     ****     S1 = ALFA(1,1,K), S2 = ALFA(1,2,K),                         MINOR.143
C     ****     S2 = ALFA(2,1,K), S4 = ALFA(2,2,K)                          MINOR.144
C     ****                                                                 MINOR.145
      DO I=1,LEN3                                                          MINOR.146
       S1(I,1)=-(PHI(1,3)+ALFA12*S9(I,1))                                  MINOR.147
       S2(I,1)=ALFA12*S8(I,1)                                              MINOR.148
       S3(I,1)=ALFA21*S9(I,1)                                              MINOR.149
       S4(I,1)=-(PHI(2,3)+ALFA21*S8(I,1))                                  MINOR.150
C      ****                                                                MINOR.151
C      ****     S12=EX(K)                                                  MINOR.151
C      ****                                                                MINOR.153
       S12(I,1)=((ALFAX1*S4(I,1)-ALFAX2*S3(I,1))*(S6(I,1)-(1.-(RMASS(1)    MINOR.154
     1          +S10(I,1))/S11(I,1))*S8(I,1))+(ALFAX2*S1(I,1)-ALFAX1*      MINOR.155
     2          S2(I,1))*(S7(I,1)-(1.-(RMASS(2)+S10(I,1))/S11(I,1))*       MINOR.156
     3          S9(I,1)))/(S1(I,1)*S4(I,1)-S2(I,1)*S3(I,1))+1.-            MINOR.157
     4          (RMX+S10(I,1))/S11(I,1)                                    MINOR.158
C      ****                                                                MINOR.159
C      ****     S10 = (DM/DZ)/MBAR                                         MINOR.160
C      ****                                                                MINOR.161
       S10(I,1)=S10(I,1)/S11(I,1)                                          MINOR.162
C      ****                                                                MINOR.163
C      ****     S11 = AX(K)                                                MINOR.164
C      ****                                                                MINOR.165
       S11(I,1)=-S11(I,1)/(TAU*RMASS(3))*(T00/S5(I,1))**0.25/(PHIX(3)      MINOR.166
     1          +ALFAX1*S8(I,1)+ALFAX2*S9(I,1))                            MINOR.167
      ENDDO                                                                MINOR.167
C     ****                                                                 MINOR.169
C     ****     S12=EX-ALFAX*D/DS(LN(T(TOT))  (THERMAL DIFFUSION TERM)      MINOR.170
C     ****                                                                 MINOR.171
      DO I=LEN1+1,LEN2                                                     MINOR.172
       S12(I,1)=S12(I,1)-ALFAX*(S5(I+LEN1,1)-S5(I-LEN1,1))/(2.*C(3)        MINOR.173
     1          *S5(I,1))                                                  MINOR.174
      ENDDO                                                                MINOR.175
C     ****                                                                 MINOR.176
C     ****     LOWER BOUNDARY AND UPPER BOUNDARY                           MINOR.177
C     ****                                                                 MINOR.178
      DO I=1,LEN1                                                          MINOR.179
       S12(I,1)=S12(I,1)-ALFAX*(S5(I+LEN1,1)-S5(I,1))/(C(3)*S5(I,1))       MINOR.180
      ENDDO                                                                MINOR.181
      DO I=1,LEN1                                                          MINOR.182
      S12(I+LEN2,1)=S12(I+LEN2,1)-ALFAX*(S5(I+LEN2,1)-                     MINOR.183
     1              S5(I+LEN2-LEN1,1))/(C(3)*S5(I+LEN2,1))                 MINOR.184
      ENDDO                                                                MINOR.185
C     ****                                                                 MINOR.186
C     ****     T7=DFACT                                                    MINOR.187
C     ****                                                                 MINOR.188
      DO I=1,LEN1                                                          MINOR.189
       T7(I)=1.                                                            MINOR.190
      ENDDO                                                                MINOR.191
      IF(ICOMP.EQ.1)CALL DFACT(T7,J,IMAXP4)                                MINOR.192
C     ****                                                                 MINOR.193
C     ****     SHAPIRO SMOOTHER,   S10=NXNM                                MINOR.194
C     ****                                                                 MINOR.195
      NXJP2K=NJP2+NXNM                                                     MINOR.196
      NXJP1K=NJP1+NXNM                                                     MINOR.197
      NXJNMK=NJ+NXNM                                                       MINOR.198
      NXJM1K=NJM1+NXNM                                                     MINOR.199
      NXJM2K=NJM2+NXNM                                                     MINOR.200
      DO I=1,LEN3                                                          MINOR.201
       S9(I,1)=S10(I,1)                                                    MINOR.202
       S8(I,1)=F(I,NXJNMK)-C(26)*(F(I,NXJP2K)+F(I,NXJM2K)-4.*              MINOR.203
     1         (F(I,NXJP1K)+F(I,NXJM1K))+6.*F(I,NXJNMK))                   MINOR.204
      ENDDO                                                                MINOR.205
      DO I=3,LEN3-2                                                        MINOR.206
       S10(I,1)=S8(I,1)-C(26)*(S8(I+2,1)+S8(I-2,1)-4.*(S8(I+1,1)+          MINOR.207
     1          S8(I-1,1))+6.*S8(I,1))                                     MINOR.208
      ENDDO                                                                MINOR.209
C     ****                                                                 MINOR.210
C     ****     S1 = P, S2 = Q, S3 = R, S4= F                               MINOR.211
C     ****                                                                 MINOR.212
      NWK=NJNP+NW-1                                                        MINOR.213
      DO K=1,KMAX                                                          MINOR.214
       NWK=NWK+1                                                           MINOR.215
       DO I=1,LEN1                                                         MINOR.216
        S1(I,K)=S11(I,K)/C(3)*(1./C(3)+.5*S12(I,K))-EXPS(K)*(C(87)*        MINOR.217
     1          DIFK(K)*T7(I)*(1./C(3)-.5*S9(I,K))+0.25*(F(I,NWK)+         MINOR.218
     2          F(I,NWK+1)))/C(3)                                          MINOR.219
        S3(I,K)=S11(I,K+1)/C(3)*(1./C(3)-.5*S12(I,K+1))-EXPS(K)*           MINOR.220
     1          (C(86)* DIFK(K+1)*T7(I)*(1./C(3)+.5*S9(I,K+1))-0.25*       MINOR.221
     2          (F(I,NWK)+F(I,NWK+1)))/C(3)                                MINOR.222
        S2(I,K)=-(S11(I,K)/C(3)*(1./C(3)-.5*S12(I,K))+S11(I,K+1)/C(3)*     MINOR.223
     1          (1./C(3)+.5*S12(I,K+1)))+EXPS(K)*((C(87)*DIFK(K)*(1./      MINOR.224
     2          C(3)+.5*S9(I,K))+C(86)*DIFK(K+1)*(1./C(3)-.5*              MINOR.225
     3          S9(I,K+1)))*T7(I)/C(3)-S14(I,K)+C(7))                      MINOR.226
        S4(I,K)=EXPS(K)*(S10(I,K)*C(7)-S13(I,K)+S15(I,K))                  MINOR.227
       ENDDO                                                               MINOR.228
      ENDDO                                                                MINOR.229
C     ****                                                                 MINOR.230
C     ****     IF IBNDB = 1, SET FLUX BOUNDARY CONDITION AT BOTTOM         MINOR.231
C     ****                                                                 MINOR.232
      IF(IBNDB.EQ.1)THEN                                                   MINOR.233
       NWK=NJNP+NW                                                         MINOR.234
       DO I=1,LEN1                                                         MINOR.235
        T1(I)=1.                                                           MINOR.236
        T2(I)=S9(I,1)-F(I,NWK)/DIFK(1)                                     MINOR.237
        T3(I)=T3(I)*C(54)*RMX/(DIFK(1)*C(81)*EXPS(1)*C(87)*C(85))          MINOR.238
       ENDDO                                                               MINOR.239
      ENDIF                                                                MINOR.240
C     ****                                                                 MINOR.241
C     ****     BOUNDARIES                                                  MINOR.242
C     ****     MODIFY EX(KMAXP1) IF IBND=1                                 MINOR.243
C     ****                                                                 MINOR.244
      IF(IBND.EQ.1)THEN                                                    MINOR.245
       NWK=NJNP+NW+KMAX                                                    MINOR.246
       DO I=1,LEN1                                                         MINOR.247
        T7(I)=EXPS(KMAX)*C(86)*F(I,NWK)/S11(I,KMAXP1)                      MINOR.248
        S12(I,KMAXP1)=S12(I,KMAXP1)-T7(I)                                  MINOR.249
       ENDDO                                                               MINOR.250
      ENDIF                                                                MINOR.251
      DO I=1,LEN1                                                          MINOR.252
C      ****                                                                MINOR.253
C      ****     LOWER BOUNDARY                                             MINOR.254
C      ****                                                                MINOR.255
       S2(I,1)=S2(I,1)+S1(I,1)*(T1(I)+.5*T2(I)*C(3))/(T1(I)-.5*T2(I)*      MINOR.256
     1         C(3))                                                       MINOR.257
       S4(I,1)=S4(I,1)-S1(I,1)*T3(I)*C(3)/(T1(I)-.5*T2(I)*C(3))            MINOR.258
       S1(I,1)=0.                                                          MINOR.259
C      ****                                                                MINOR.260
C      ****     UPPER BOUNDARY                                             MINOR.261
C      ****                                                                MINOR.262
       IF(IBND.EQ.0.OR.IBND.EQ.1)THEN                                      MINOR.263
C       ****                                                               MINOR.264
C       ****     UPWARD NUMBER FLUX IS IN T4                               MINOR.265
C       ****                                                               MINOR.266
        S1(I,KMAXP1)=1.+.5*C(3)*S12(I,KMAXP1)                              MINOR.267
        S2(I,KMAXP1)=S1(I,KMAXP1)-2                                        MINOR.268
        S3(I,KMAXP1)=0.                                                    MINOR.269
        S4(I,KMAXP1)=-C(54)*RMX*T4(I)*C(3)/(C(81)*S11(I,KMAXP1)*C(85))     MINOR.270
       ELSE                                                                MINOR.271
C       ****                                                               MINOR.272
C       ****     VALUE AT UPPER BNDRY IN T4                                MINOR.273
C       ****                                                               MINOR.274
        S1(I,KMAXP1)=.5                                                    MINOR.275
        S2(I,KMAXP1)=.5                                                    MINOR.276
        S3(I,KMAXP1)=0.                                                    MINOR.277
        S4(I,KMAXP1)=T4(I)                                                 MINOR.278
       ENDIF                                                               MINOR.279
      ENDDO                                                                MINOR.280
C     ****                                                                 MINOR.281
C     ****     SOLVE TRIDIAGONAL SYSTEM                                    MINOR.282
C     ****                                                                 MINOR.283
      NXNPK=NJNP+NX                                                        MINOR.284
      CALL TRSOLV(S1,S2,S3,S4,S7,F(1,NXNPK),LEN1,3,LEN1-2,KMAXP1,1,        MINOR.285
     1            KMAXP1,1)                                                MINOR.286
C     ****                                                                 MINOR.287
C     ****     FILTER NX                                                   MINOR.288
C     ****                                                                 MINOR.289
      IF(KUTT(J).LT.IMAXH)THEN                                             MINOR.290
       NXNPK=NJNP+NX                                                       MINOR.291
       CALL FILTER2(NXNPK,KMAXP1,KUTT(J))                                  MINOR.292
      ENDIF                                                                MINOR.293
C     ****                                                                 MINOR.294
C     ****     TIME SMOOTHING                                              MINOR.295
C     ****                                                                 MINOR.296
      NXNMK=NJ+NXNM-1                                                      MINOR.297
      NXK=NJ+NX-1                                                          MINOR.298
      NXNPK=NJNP+NX-1                                                      MINOR.299
      NXMNK=NJNP+NXNM-1                                                    MINOR.300
      DO K=1,KMAXP1                                                        MINOR.301
       NXNMK=NXNMK+1                                                       MINOR.302
       NXK=NXK+1                                                           MINOR.303
       NXNPK=NXNPK+1                                                       MINOR.304
       NXMNK=NXMNK+1                                                       MINOR.305
       DO I=3,IMAX+2                                                       MINOR.306
        F(I,NXMNK)=C(30)*F(I,NXK)+C(31)*(F(I,NXNMK)+F(I,NXNPK))            MINOR.307
       ENDDO                                                               MINOR.308
      ENDDO                                                                MINOR.309
C     ****                                                                 MINOR.310
C     ****    PERIODIC POINTS                                              MINOR.311
C     ****                                                                 MINOR.312
      NXJM1K=NJM1+NX-1                                                     MINOR.313
      NXJK=NJ+NX-1                                                         MINOR.314
      NXJP1K=NJP1+NX-1                                                     MINOR.315
      NMXJM1K=NJM1+NXNM-1                                                  MINOR.316
      NMXJK=NJ+NXNM-1                                                      MINOR.317
      NMXJP1K=NJP1+NXNM-1                                                  MINOR.318
      DO K=1,KMAX+1                                                        MINOR.319
       NXJM1K=NXJM1K+1                                                     MINOR.320
       NXJK=NXJK+1                                                         MINOR.321
       NXJP1K=NXJP1K+1                                                     MINOR.322
       NMXJM1K=NMXJM1K+1                                                   MINOR.323
       NMXJK=NMXJK+1                                                       MINOR.324
       NMXJP1K=NMXJP1K+1                                                   MINOR.325
       DO I=1,2                                                            MINOR.326
        F(I,NXJM1K)=F(I+IMAX,NXJM1K)                                       MINOR.327
        F(I+IMAX+2,NXJM1K)=F(I+2,NXJM1K)                                   MINOR.328
        F(I,NXJK)=F(I+IMAX,NXJK)                                           MINOR.329
        F(I+IMAX+2,NXJK)=F(I+2,NXJK)                                       MINOR.330
        F(I,NXJP1K)=F(I+IMAX,NXJP1K)                                       MINOR.331
        F(I+IMAX+2,NXJP1K)=F(I+2,NXJP1K)                                   MINOR.332
        F(I,NMXJM1K)=F(I+IMAX,NMXJM1K)                                     MINOR.333
        F(I+IMAX+2,NMXJM1K)=F(I+2,NMXJM1K)                                 MINOR.334
        F(I,NMXJK)=F(I+IMAX,NMXJK)                                         MINOR.335
        F(I+IMAX+2,NMXJK)=F(I+2,NMXJK)                                     MINOR.336
        F(I,NMXJP1K)=F(I+IMAX,NMXJP1K)                                     MINOR.337
        F(I+IMAX+2,NMXJP1K)=F(I+2,NMXJP1K)                                 MINOR.338
       ENDDO                                                               MINOR.339
      ENDDO                                                                MINOR.340
C     ****                                                                 MINOR.341
C     ****    INSURE NON-NEGATIVE NX                                       MINOR.342
C     ****                                                                 MINOR.343
      NXJM1K=NJM1+NX                                                       MINOR.344
      NXJK=NJ+NX                                                           MINOR.345
      NXJP1K=NJP1+NX                                                       MINOR.346
      NMXJM1K=NJM1+NXNM                                                    MINOR.347
      NMXJK=NJ+NXNM                                                        MINOR.348
      NMXJP1K=NJP1+NXNM                                                    MINOR.349
      DO K=2,KMAX                                                          MINOR.350
       NXJM1K=NXJM1K+1                                                     MINOR.351
       NXJK=NXJK+1                                                         MINOR.352
       NXJP1K=NXJP1K+1                                                     MINOR.353
       NMXJM1K=NMXJM1K+1                                                   MINOR.354
       NMXJK=NMXJK+1                                                       MINOR.355
       NMXJP1K=NMXJP1K+1                                                   MINOR.356
       DO I=3,IMAX+2                                                       MINOR.357
        S11(I,K)=0.1*(F(I+1,NXJK)+F(I-1,NXJK)+F(I,NXJM1K)+                 MINOR.358
     1           F(I,NXJP1K)+F(I,NXJK-1)+F(I,NXJK+1)+F(I-1,NXJM1K)+        MINOR.359
     2           F(I-1,NXJP1K)+F(I+1,NXJM1K)+F(I+1,NXJP1K))                MINOR.360
       S12(I,K)=0.1*(F(I+1,NMXJK)+F(I-1,NMXJK)+F(I,NMXJM1K)+               MINOR.361
     1          F(I,NMXJP1K)+F(I,NMXJK-1)+F(I,NMXJK+1)+F(I-1,NMXJM1K)+     MINOR.362
     2          F(I-1,NMXJP1K)+F(I+1,NMXJM1K)+F(I+1,NMXJP1K))              MINOR.363
       ENDDO                                                               MINOR.364
      ENDDO                                                                MINOR.365
      DO I=3,IMAX+2                                                        MINOR.366
       S11(I,1)=SMALL                                                      MINOR.367
       S11(I,KMAXP1)=SMALL                                                 MINOR.368
       S12(I,1)=SMALL                                                      MINOR.369
       S12(I,KMAXP1)=SMALL                                                 MINOR.370
      ENDDO                                                                MINOR.371
      NXK=NJNP+NX-1                                                        MINOR.372
      NXNMK=NJNP+NXNM-1                                                    MINOR.373
      DO K=1,KMAXP1                                                        MINOR.374
       NXK=NXK+1                                                           MINOR.375
       NXNMK=NXNMK+1                                                       MINOR.376
       DO I=3,IMAX+2                                                       MINOR.377
        IF(F(I,NXK).LT.SMALL)F(I,NXK)=S11(I,K)                             MINOR.378
        IF(F(I,NXNMK).LT.SMALL)F(I,NXNMK)=S12(I,K)                         MINOR.379
       ENDDO                                                               MINOR.380
      ENDDO                                                                MINOR.381
      RETURN                                                               MINOR.382
      END                                                                  MINOR.383
C                                                                          MINOR.384
*DK NEW                                                                      NEW.1
      SUBROUTINE NEW(TR,RNU)                                                 NEW.2
C     ****                                                                   NEW.3
C     ****     CALCULATES FACTORS FOR NU MATRIX AND RETURNS IN MATRIX        NEW.4
C     ****     RNU                                                           NEW.5
C     ****                                                                   NEW.6
C     ****     TR = .5*(TI+TN)                                               NEW.7
C     ****                                                                   NEW.8
      INCLUDE 'param.h'                                                      NEW.9
      INCLUDE 'const.h'                                                      NEW.10
      DIMENSION TR(ZIMXP,ZKMXP),RNU(ZIMXP,ZKMXP,3,3)                         NEW.11
      COMMON/MASS/RMN4S,RMN2D,RMNO,BRN2D,COLFAC                              NEW.12
C     ****                                                                   NEW.13
C     ****     SET MATRIX                                                    NEW.14
C     ****                                                                   NEW.15
      DO I=1,LEN2                                                            NEW.16
C      ****                                                                  NEW.17
C      ****          O2+    -    O2                                          NEW.18
C      ****                                                                  NEW.19
       RNU(I,1,1,1)=2.59D-11*DSQRT(TR(I,1))*                                 NEW.20
     1              (1.-0.073*DLOG10(TR(I,1)))**2                            NEW.21
C      ****                                                                  NEW.22
C      ****          O+     -    O2                                          NEW.23
C      ****                                                                  NEW.24
       RNU(I,1,2,1)=6.64D-10                                                 NEW.25
C      ****                                                                  NEW.26
C      ****          NO+    -    O2                                          NEW.27
C      ****                                                                  NEW.28
       RNU(I,1,3,1)=4.27D-10                                                 NEW.29
C      ****                                                                  NEW.30
C      ****          O2+    -     O                                          NEW.31
C      ****                                                                  NEW.32
       RNU(I,1,1,2)=2.31D-10                                                 NEW.33
C      ****                                                                  NEW.34
C      ****          O+     -     O                                          NEW.35
C      ****                                                                  NEW.36
       RNU(I,1,2,2)=3.67D-11*DSQRT(TR(I,1))*(1-0.064*DLOG10(TR(I,1)))**      NEW.37
     1              2.*COLFAC                                                NEW.38
C      ****                                                                  NEW.39
C      ****          NO+    -     O                                          NEW.40
C      ****                                                                  NEW.41
       RNU(I,1,3,2)=2.44D-10                                                 NEW.41
C      ****                                                                  NEW.43
C      ****          O2+    -    N2                                          NEW.44
C      ****                                                                  NEW.45
       RNU(I,1,1,3)=4.13D-10                                                 NEW.46
C      ****                                                                  NEW.47
C      ****          O+     -    N2                                          NEW.48
C      ****                                                                  NEW.49
       RNU(I,1,2,3)=6.82D-10                                                 NEW.50
C      ****                                                                  NEW.51
C      ****          NO+    -    N2                                          NEW.52
C      ****                                                                  NEW.53
       RNU(I,1,3,3)=4.34D-10                                                 NEW.54
      ENDDO                                                                  NEW.55
      RETURN                                                                 NEW.56
      END                                                                    NEW.57
C                                                                            NEW.58
*DK NEWTO3P                                                              NEWTO3P.1
      SUBROUTINE NEWTO3P                                                 NEWTO3P.2
C     ****                                                               NEWTO3P.3
C     ****     E.C.RIDLEY 7/9/87                                         NEWTO3P.4
C     ****                                                               NEWTO3P.5
C     ****     ADDS IMPLICIT AND EXPLICIT CONTRIBUTIONS TO COOLING TO    NEWTO3P.6
C     ****     NWTI AND NWTE RESPECTIVELY.  S11 AND S12 ARE WORK SPACE.  NEWTO3P.7
C     ****                                                               NEWTO3P.8
C     ****     COMMON BLOCKS                                             NEWTO3P.9
      INCLUDE 'param.h'                                                  NEWTO3P.10
      INCLUDE 'vscrw.h'                                                  NEWTO3P.11
      INCLUDE 'const.h'                                                  NEWTO3P.12
      INCLUDE 'index.h'                                                  NEWTO3P.13
      INCLUDE 'buffe.h'                                                  NEWTO3P.14
      DIMENSION AN(3),BN(3),XFAC(ZKMXP)                                  NEWTO3P.15
C     ****                                                               NEWTO3P.16
C     ****     CHANGE O(3P) COOLING FACTOR FROM 0.5 TO 1.0 OF THE BATES  NEWTO3P.17
C     ****       EXPRESSION                                              NEWTO3P.18
C     ****                                                               NEWTO3P.19
      DATA AN/0.835D-18,0.6,0.2/,BN/228.,228.,325./,XFAC/3*.01,.05,.1,   NEWTO3P.20
     1.2,.4,.55,.7,.75,19*.8/                                            NEWTO3P.21
      NTK=NJ+NT                                                          NEWTO3P.22
      NPS2K=NJ+NPS2                                                      NEWTO3P.23
      NCPK=NCP                                                           NEWTO3P.24
      DO K=1,KMAX                                                        NEWTO3P.25
       DO I=1,LEN1                                                       NEWTO3P.26
C       ****                                                             NEWTO3P.27
C       ****     S11=AN(1)*XFAC*N0*PSI2/M2*EXP(-BN(1)/T)                 NEWTO3P.28
C       ****                                                             NEWTO3P.29
        S11(I,K)=AN(1)*.5*(XFAC(K)+XFAC(K+1))*C(85)/RMASS(2)             NEWTO3P.30
       ENDDO                                                             NEWTO3P.31
      ENDDO                                                              NEWTO3P.32
      NWTIK=NWTI                                                         NEWTO3P.33
      DO I=1,LEN2                                                        NEWTO3P.34
       S11(I,1)=S11(I,1)*F(I,NPS2K)*DEXP(-BN(1)/F(I,NTK))                NEWTO3P.35
C      ****                                                              NEWTO3P.36
C      ****     S12=1.+AN(2)*EXP(-BN(2)/T)+AN(3)*EXP(-BN(3)/T)           NEWTO3P.37
C      ****                                                              NEWTO3P.38
       S12(I,1)=1.+AN(2)*DEXP(-BN(2)/F(I,NTK))+AN(3)*DEXP(-BN(3)         NEWTO3P.39
     1          /F(I,NTK))                                               NEWTO3P.40
C      ****                                                              NEWTO3P.41
C      ****     S11=S11/S12= F(T(N))                                     NEWTO3P.42
C      ****                                                              NEWTO3P.43
       S11(I,1)=S11(I,1)/S12(I,1)                                        NEWTO3P.44
C      ****                                                              NEWTO3P.45
C      ****     S12=DF/DT=S11/S12/T**2*(BN(1)+(BN(1)-BN(3))*AN(3)*       NEWTO3P.46
C      ****          EXP(-BN(3)/T))                                      NEWTO3P.47
C      ****                                                              NEWTO3P.48
       S12(I,1)=S11(I,1)/S12(I,1)/F(I,NTK)**2*(BN(1)+(BN(1)-BN(3))*      NEWTO3P.49
     1          AN(3)*DEXP(-BN(3)/F(I,NTK)))                             NEWTO3P.50
C      ****                                                              NEWTO3P.51
C      ****     ADD IMPLICIT CONTRIBUTIONS TO NWTI                       NEWTO3P.52
C      ****                                                              NEWTO3P.53
       F(I,NWTIK)=F(I,NWTIK)+S12(I,1)/(.5*(F(I,NCPK)+F(I,NCPK+1)))       NEWTO3P.54
C      ****                                                              NEWTO3P.55
C      ****     ADD EXPLICIT CONTRIBUTIONS TO S10                        NEWTO3P.56
C      ****                                                              NEWTO3P.57
       S11(I,1)=S11(I,1)-F(I,NTK)*S12(I,1)                               NEWTO3P.58
      ENDDO                                                              NEWTO3P.59
      NWTEK=NWTE-1                                                       NEWTO3P.60
      DO K=1,KMAX                                                        NEWTO3P.61
       NWTEK=NWTEK+1                                                     NEWTO3P.62
       DO I=1,LEN1                                                       NEWTO3P.63
        F(I,NWTEK)=F(I,NWTEK)+S11(I,K)*EXPS(K)                           NEWTO3P.64
       ENDDO                                                             NEWTO3P.65
      ENDDO                                                              NEWTO3P.66
      RETURN                                                             NEWTO3P.67
      END                                                                NEWTO3P.68
C                                                                        NEWTO3P.69
*DK NEWTON                                                                NEWTON.1
      SUBROUTINE NEWTON                                                   NEWTON.2
C     ****                                                                NEWTON.3
C     ****     E.C.RIDLEY     11/24/86                                    NEWTON.4
C     ****     CALCULATE IMPLICIT & EXPLICIT COOLING TERMS IN NWTI &      NEWTON.5
C     ****     NWTE. S9, S10, S11 AND S12 ARE USED AS WORK SPACE.         NEWTON.6
C     ****                                                                NEWTON.7
      INCLUDE 'param.h'                                                   NEWTON.8
      INCLUDE 'vscrw.h'                                                   NEWTON.9
      INCLUDE 'const.h'                                                   NEWTON.10
      INCLUDE 'index.h'                                                   NEWTON.11
      INCLUDE 'buffe.h'                                                   NEWTON.12
      REAL*8 NOB                                                          NEWTON.13
      COMMON/RUNT/TTBOUND,NOB(ZJMX),AVTO,HOR(ZJMX)                        NEWTON.14
      DATA RMCO2/44./                                                     NEWTON.15
      DATA XCO2U/350.D-6/                                                 NEWTON.16
      COMMON/MASS/ RMN4S,RMN2D,RMNO,BRN2D,CEE                             NEWTON.17
C     ****                                                                NEWTON.18
C     ****     S10 = INTEGRAL(M(C02)*DZ/MBAR)                             NEWTON.19
C     ****                                                                NEWTON.20
      NMSK=NJ+NMS                                                         NEWTON.21
C     ****                                                                NEWTON.22
C     ****     LOWEST LEVEL                                               NEWTON.23
C     ****                                                                NEWTON.24
      DO I=1,LEN1                                                         NEWTON.25
       S10(I,1)=.25*RMCO2*(1./F(I,NMSK)+1./F(I,NMSK+1))*C(3)              NEWTON.26
      ENDDO                                                               NEWTON.27
C     ****                                                                NEWTON.28
C     ****     LEVELS 2 THRU KMAX                                         NEWTON.29
C     ****                                                                NEWTON.30
      DO K=2,KMAX                                                         NEWTON.31
       NMSK=NMSK+1                                                        NEWTON.32
       DO I=1,LEN1                                                        NEWTON.33
        S10(I,K)=S10(I,K-1)+RMCO2/F(I,NMSK)*C(3)                          NEWTON.34
       ENDDO                                                              NEWTON.35
      ENDDO                                                               NEWTON.36
      NCPK=NCP-1                                                          NEWTON.37
      NTK=NJ+NT-1                                                         NEWTON.38
      NPS1K=NJ+NPS-1                                                      NEWTON.39
      NPS2K=NJ+NPS2-1                                                     NEWTON.40
      NMSK=NJ+NMS-1                                                       NEWTON.41
      NWTIK=NWTI-1                                                        NEWTON.42
      NWTEK=NWTE-1                                                        NEWTON.43
      NPNOK=NJ+NPNO-1                                                     NEWTON.44
      DO K=1,KMAX                                                         NEWTON.45
       NCPK=NCPK+1                                                        NEWTON.46
       NTK=NTK+1                                                          NEWTON.47
       NPS1K=NPS1K+1                                                      NEWTON.48
       NPS2K=NPS2K+1                                                      NEWTON.49
       NMSK=NMSK+1                                                        NEWTON.50
       NWTIK=NWTIK+1                                                      NEWTON.51
       NWTEK=NWTEK+1                                                      NEWTON.52
       NPNOK=NPNOK+1                                                      NEWTON.53
       DO I=1,LEN1                                                        NEWTON.54
C       ****                                                              NEWTON.55
C       ****     S10 = N(CO2)                                             NEWTON.56
C       ****                                                              NEWTON.57
        S10(I,K)=XCO2U*C(81)*EXPS(1)*C(87)/(C(84)*F(I,NTK))*              NEWTON.58
     1           DEXP(-S10(I,K))                                          NEWTON.59
C       ****                                                              NEWTON.60
C       ****     S11 = A(CO2)                                             NEWTON.61
C       ****     S12 = B(CO2)                                             NEWTON.62
C       ****                                                              NEWTON.63
        IF((F(I,NTK)-200.).GE.0.)THEN                                     NEWTON.64
         S11(I,K)=2.5D-15*(1+0.03d0*(F(I,NTK)-200))                       NEWTON.65
        ELSE                                                              NEWTON.66
         S11(I,K)=2.5D-15                                                 NEWTON.67
        ENDIF                                                             NEWTON.68
        IF((F(I,NTK)-300.).GE.0.)THEN                                     NEWTON.69
         S12(I,K)=AVTO*F(I,NTK)/300.                                      NEWTON.70
        ELSE                                                              NEWTON.71
         S12(I,K)=AVTO                                                    NEWTON.72
        ENDIF                                                             NEWTON.73
C       ****                                                              NEWTON.74
C       ****     S12 = CO2 CONTRIBUTION TO COOLING.                       NEWTON.75
C       ****                                                              NEWTON.76
        S12(I,K)=2.65D-13*S10(I,K)*DEXP(-960./F(I,NTK))*C(85)*            NEWTON.77
     1           ((F(I,NPS1K)/RMASS(1)+(1.-F(I,NPS1K)-F(I,NPS2K))/        NEWTON.78
     2           RMASS(3))*S11(I,K)+F(I,NPS2K)/RMASS(2)*S12(I,K))         NEWTON.79
C       ****                                                              NEWTON.80
C       ****     S10 = N(NO)/RHO                                          NEWTON.81
C       ****                                                              NEWTON.82
        S10(I,K)=C(85)*F(I,NPNOK)/RMNO                                    NEWTON.83
C       ****                                                              NEWTON.84
C       ****     S11 = A(NO)                                              NEWTON.85
C       ****                                                              NEWTON.86
        S11(I,K)=.5*(F(I,NMSK)+F(I,NMSK+1))*C(85)*C(81)*EXPS(K)/(C(57)*   NEWTON.87
     1           F(I,NTK))*(6.5D-11*F(I,NPS2K)/RMASS(2)+2.4D-14*          NEWTON.88
     2           F(I,NPS1K)/RMASS(1))                                     NEWTON.89
C       ****                                                              NEWTON.90
C       ****     FORM NO COOLING CONTRIBUTION IN S11                      NEWTON.91
C       ****                                                              NEWTON.92
        S11(I,K)=4.956D-12*S10(I,K)*(S11(I,K)/(S11(I,K)+13.3))*           NEWTON.93
     1           DEXP(-2700./F(I,NTK))                                    NEWTON.94
C       ****                                                              NEWTON.95
C       ****     FORM TOTAL COOLING TERMS IN S9, S10                      NEWTON.96
C       ****                                                              NEWTON.97
        F(I,NWTIK)=(2700.*S11(I,K)+960.*S12(I,K))/(.5*(F(I,NCPK)+         NEWTON.98
     1             F(I,NCPK+1))*F(I,NTK)**2)                              NEWTON.99
        F(I,NWTEK)=((1-2700./F(I,NTK))*S11(I,K)+(1.-960./F(I,NTK))*       NEWTON.100
     1             S12(I,K))*EXPS(K)                                      NEWTON.101
       ENDDO                                                              NEWTON.102
      ENDDO                                                               NEWTON.103
      RETURN                                                              NEWTON.104
      END                                                                 NEWTON.105
C                                                                         NEWTON.106
*DK OPFLUX                                                                OPFLUX.1
      SUBROUTINE OPFLUX                                                   OPFLUX.2
C     ****                                                                OPFLUX.3
C     ****     CALCULATES UPWARD O+ NUMBER FLUX IN T7                     OPFLUX.4
C     ****                                                                OPFLUX.5
      INCLUDE 'param.h'                                                   OPFLUX.6
      INCLUDE 'vscrw.h'                                                   OPFLUX.7
      INCLUDE 'const.h'                                                   OPFLUX.8
      INCLUDE 'phycs.h'                                                   OPFLUX.9
      INCLUDE 'start.h'                                                   OPFLUX.10
      COMMON/TRGM/RLATM(ZIMXP,ZJMX),RLONM(ZIMXP,ZJMX),                    OPFLUX.11
     1      DIPMAG(ZIMXP,ZJMX),DECMAG(ZIMXP,ZJMX),SNDEC(ZIMXP,ZJMX),      OPFLUX.12
     2      CSDC(ZIMXP,ZJMX),SN2DEC(ZIMXP,ZJMX),SNCSDC(ZIMXP,ZJMX),       OPFLUX.13
     3      RLATMP(ZJMX),RLONMP(ZJMX),DLONS(ZJMX)                         OPFLUX.14
C     ****                                                                OPFLUX.15
C     ****     SET PHID AND PHIN                                          OPFLUX.16
C     ****                                                                OPFLUX.17
      DATA PHID,PHIN/1.5D8,-1.5D8/                                        OPFLUX.18
C     ****                                                                OPFLUX.19
C     ****     RADIANS TO DEGREES                                         OPFLUX.20
C     ****                                                                OPFLUX.21
      RTD = 180.d0/C(110)                                                 OPFLUX.22
C     ****                                                                OPFLUX.23
C     ****    CALCULATE O+ FLUX AT UPPER BOUNDARY                         OPFLUX.24
C     ****                                                                OPFLUX.25
C     ****    CALCULATE SOLAR ZENITH ANGLE, CHI                           OPFLUX.26
C     ****                                                                OPFLUX.27
      RLAT=-.5*C(110)*DBLE(1-NHEMI)+(DBLE(J-1)+.5)*C(2)                   OPFLUX.28
      COSLAT=DCOS(RLAT)                                                   OPFLUX.29
      SINLAT=DSIN(RLAT)                                                   OPFLUX.30
      DO I=1,LEN1                                                         OPFLUX.31
C      ****                                                               OPFLUX.32
C      ****     T2 = LOCAL TIME                                           OPFLUX.33
C      ****                                                               OPFLUX.34
      T2(I)=DMOD(SECS/3600.+(C(1)*DBLE(I-3)+C(110))*12./C(110),24.D0)       OPFLUX.35
C      ****                                                               OPFLUX.36
C      ****     T2 = CHI                                                  OPFLUX.37
C      ****                                                               OPFLUX.38
       T2(I)=DACOS(C(95)*SINLAT+C(96)*COSLAT*DCOS(C(110)*(T2(I)-12.)      OPFLUX.39
     1       /12.))                                                       OPFLUX.40
C      ****                                                               OPFLUX.41
C      ****     T3 = A = .5*(1.+SIN(PI*(ABS(RLATM)-PI/6.)/(PI/3.)))       OPFLUX.42
C      ****               FOR  ABS(RLATM).LT.PI/3.                        OPFLUX.43
C      ****          A = 1.    FOR  ABS(RLATM).GE.PI/3                    OPFLUX.44
C      ****                                                               OPFLUX.45
       IF((DABS(RLATM(I,J))-C(110)/12.d0).GE.0.)THEN                      OPFLUX.46
        T3(I)=1.                                                          OPFLUX.47
       ELSE                                                               OPFLUX.48
        T3(I)=.5*(1.+DSIN(C(110)*(DABS(RLATM(I,J))-C(110)/                OPFLUX.49
     1        24.)/(C(110)/12.)))                                         OPFLUX.50
       ENDIF                                                              OPFLUX.51
C      ****                                                               OPFLUX.52
C      ****     T4 = FED       T5 = FEN                                   OPFLUX.53
C      ****                                                               OPFLUX.54
       T4(I)=PHID*T3(I)                                                   OPFLUX.55
       T5(I)=PHIN*T3(I)                                                   OPFLUX.56
C      ****                                                               OPFLUX.57
C      ****     T1 = FE                                                   OPFLUX.58
C      ****                                                               OPFLUX.59
       IF((T2(I)-.5*C(110)).GE.0.)THEN                                    OPFLUX.60
        T7(I)=T5(I)                                                       OPFLUX.61
       ELSE                                                               OPFLUX.62
        T7(I)=T4(I)                                                       OPFLUX.63
       ENDIF                                                              OPFLUX.64
       IF(((T2(I)*RTD-80.)*(T2(I)*RTD-100.)).LT.0.)THEN                   OPFLUX.65
        T7(I)=.5*(T4(I)+T5(I))+.5*(T4(I)-T5(I))                           OPFLUX.66
     1        *DCOS(C(110)*(T2(I)*RTD-80.)/200.)                          OPFLUX.67
       ENDIF                                                              OPFLUX.68
      ENDDO                                                               OPFLUX.69
      RETURN                                                              OPFLUX.70
      END                                                                 OPFLUX.71
C                                                                         OPFLUX.72
*DK OPLUS                                                                  OPLUS.1
      SUBROUTINE OPLUS                                                     OPLUS.2
C     ****                                                                 OPLUS.3
C     ****     ADVANCES N(O+) BY ONE TIME STEP                             OPLUS.4
C     ****                                                                 OPLUS.5
C     ****     ON ENTRY, T7 = UPWARD NUMBER FLUX OF O+ AT TOP              OPLUS.6
C     ****                                                                 OPLUS.7
      INCLUDE 'param.h'                                                    OPLUS.8
      INCLUDE 'vscrw.h'                                                    OPLUS.9
      INCLUDE 'const.h'                                                    OPLUS.10
      INCLUDE 'index.h'                                                    OPLUS.11
      INCLUDE 'buffe.h'                                                    OPLUS.12
      INCLUDE 'phycs.h'                                                    OPLUS.13
      INCLUDE 'rates.h'                                                    OPLUS.14
C     ****                                                                 OPLUS.15
C     ****     COMMON BLOCK DESCRIBING MAGNETIC FIELD                      OPLUS.16
C     ****                                                                 OPLUS.17
      COMMON/MAGFLD/BXM(ZIMXP,2),BX(ZIMXP,ZJMX),BXP(ZIMXP,4),              OPLUS.18
     1      BY(ZIMXP,ZJMX),BYP(ZIMXP,4),BZ(ZIMXP,ZJMX),BZP(ZIMXP,4),       OPLUS.19
     2      BMOD(ZIMXP,ZJMX),BMODP(ZIMXP,2)                                OPLUS.20
      DIMENSION KUTT(ZJMX),XNEU(ZIMXP,ZKMXP)                               OPLUS.21
      DATA KUTT/1,2,3,5,6,7,9,10,11,13,14,15,17,10*17,17,15,14,13,11,10,   OPLUS.25
     19,7,6,5,3,2,1/                                                       OPLUS.26
      COMMON/MASS/RMN4S,RMN2D,RMNO,BRN2D,CEE                               OPLUS.27
      DATA RMOP/16./                                                       OPLUS.28
      DATA EXPLIC/1./                                                      OPLUS.29
C     ****                                                                 OPLUS.30
C     ****      T1 = DIV(B)                                                OPLUS.31
C     ****                                                                 OPLUS.32
      CALL DIVB(T1,J)                                                      OPLUS.33
C     ****                                                                 OPLUS.34
C     ****     CALCULATE 2*TP (PLASMA TEMPERATURE) AT J-1, J, AND J+1      OPLUS.35
C     ****                                                                 OPLUS.36
      NTJM1K=NJM1+NT                                                       OPLUS.37
      NTK=NJ+NT                                                            OPLUS.38
      NTJP1K=NJP1+NT                                                       OPLUS.39
      NTEM1K=NJM1+NTE                                                      OPLUS.40
      NTEK=NJ+NTE                                                          OPLUS.41
      NTEP1K=NJP1+NTE                                                      OPLUS.42
      NTIM1K=NJM1+NTI                                                      OPLUS.43
      NTIK=NJ+NTI                                                          OPLUS.44
      NTIP1K=NJP1+NTI                                                      OPLUS.45
      DO I=1,LEN2                                                          OPLUS.46
       S4(I,1)=0.5*(F(I,NTEM1K)+F(I,NTIM1K))                               OPLUS.47
       S5(I,1)=0.5*(F(I,NTEK)+F(I,NTIK))                                   OPLUS.48
       S6(I,1)=0.5*(F(I,NTEP1K)+F(I,NTIP1K))                               OPLUS.49
      ENDDO                                                                OPLUS.50
C     ****                                                                 OPLUS.51
C     ****     CALCULATE DIFFUSION COEFFICIENT AT J-1, J, AND J+1          OPLUS.52
C     ****                                                                 OPLUS.53
      NMSM1K=NJM1+NMS                                                      OPLUS.54
      NMSK=NJ+NMS                                                          OPLUS.55
      NMSP1K=NJP1+NMS                                                      OPLUS.56
      NPS1MK=NJM1+NPS                                                      OPLUS.57
      NPS1K=NJ+NPS                                                         OPLUS.58
      NPS1PK=NJP1+NPS                                                      OPLUS.59
      NPS2MK=NJM1+NPS2                                                     OPLUS.60
      NPS2K=NJ+NPS2                                                        OPLUS.61
      NPS2PK=NJP1+NPS2                                                     OPLUS.62
      CALL RRK(F(1,NTJM1K),F(1,NMSM1K),F(1,NPS1MK),F(1,NPS2MK),S4,S13)     OPLUS.63
      CALL RRK(F(1,NTK),F(1,NMSK),F(1,NPS1K),F(1,NPS2K),S5,S14)            OPLUS.64
      CALL RRK(F(1,NTJP1K),F(1,NMSP1K),F(1,NPS1PK),F(1,NPS2PK),S6,S15)     OPLUS.65
C     ****                                                                 OPLUS.66
C     ****      S4 = 2.*TP(J-1), S5 = 2.*TP(J), S6 = 2.*TP(J+1)            OPLUS.67
C     ****                                                                 OPLUS.68
      DO I=1,LEN2                                                          OPLUS.69
       S4(I,1)=2.*S4(I,1)                                                  OPLUS.70
       S5(I,1)=2.*S5(I,1)                                                  OPLUS.71
       S6(I,1)=2.*S6(I,1)                                                  OPLUS.72
      ENDDO                                                                OPLUS.73
C     ****                                                                 OPLUS.74
C     ****     CALCULATE SCALE HEIGHT AR J-1, J, AND J+1                   OPLUS.75
C     ****                                                                 OPLUS.76
      DO I=1,LEN2                                                          OPLUS.77
       S10(I,1)=C(57)*F(I,NTJM1K)/(.5*(F(I,NMSM1K)+F(I,NMSM1K+1))*C(54))   OPLUS.78
       S11(I,1)=C(57)*F(I,NTK)/(.5*(F(I,NMSK)+F(I,NMSK+1))*C(54))          OPLUS.79
       S12(I,1)=C(57)*F(I,NTJP1K)/(.5*(F(I,NMSP1K)+F(I,NMSP1K+1))*C(54))   OPLUS.80
      ENDDO                                                                OPLUS.81
C     ****                                                                 OPLUS.82
C     ****      S7 = (D/(H*DZ)*2.*TP+M*G/R)*N(O+)   (J-1)                  OPLUS.83
C     ****      S8 = (D/(H*DZ)*2.*TP+M*G/R)*N(O+)     (J)                  OPLUS.84
C     ****      S9 = (D/(H*DZ)*2.*TP+M*G/R)*N(O+)   (J+1)                  OPLUS.85
C     ****                                                                 OPLUS.86
      NOPM1K=NJM1+NOP                                                      OPLUS.87
      NOPK=NJ+NOP                                                          OPLUS.88
      NOPP1K=NJP1+NOP                                                      OPLUS.89
      CALL DIFFUS(S4,F(1,NOPM1K),S10,S7)                                   OPLUS.90
      CALL DIFFUS(S5,F(1,NOPK),S11,S8)                                     OPLUS.91
      CALL DIFFUS(S6,F(1,NOPP1K),S12,S9)                                   OPLUS.92
C     ****                                                                 OPLUS.93
C     ****      S9 = (B(H).DEL(H))*(D/(H*DZ)*TP+M*G/R)*N(O+)   (J)         OPLUS.94
C     ****                                                                 OPLUS.95
      CALL BDOTDH(S7,S8,S9,J,S9)                                           OPLUS.96
C     ****                                                                 OPLUS.97
C     ****      S9 = D*BZ*S9         (J)                                   OPLUS.98
C     ****                                                                 OPLUS.99
      DO K=1,KMAX                                                          OPLUS.100
       DO I=1,LEN1                                                         OPLUS.101
        S9(I,K)=S14(I,K)*BZ(I,J)*S9(I,K)                                   OPLUS.102
       ENDDO                                                               OPLUS.103
      ENDDO                                                                OPLUS.104
C     ****                                                                 OPLUS.105
C     ****      S3 = 2.*TP*N(O+)    (J-2)                                  OPLUS.106
C     ****      S4 = 2.*TP*N(O+)    (J-1)                                  OPLUS.107
C     ****      S5 = 2.*TP*N(O+)    (J)                                    OPLUS.108
C     ****      S6 = 2.*TP*N(O+)    (J+1)                                  OPLUS.109
C     ****      S7 = 2.*TP*N(O+)    (J+2)                                  OPLUS.110
C     ****                                                                 OPLUS.111
      NTEM2K=NJM2+NTE                                                      OPLUS.112
      NTEP2K=NJP2+NTE                                                      OPLUS.113
      NOPM2K=NJM2+NOP                                                      OPLUS.114
      NOPP2K=NJP2+NOP                                                      OPLUS.115
      NTIM2K=NJM2+NTI                                                      OPLUS.116
      NTIP2K=NJP2+NTI                                                      OPLUS.117
      DO I=1,LEN2                                                          OPLUS.118
       S3(I,1)=F(I,NOPM2K)*(F(I,NTEM2K)+F(I,NTIM2K))                       OPLUS.119
       S4(I,1)=S4(I,1)*F(I,NOPM1K)                                         OPLUS.120
       S5(I,1)=S5(I,1)*F(I,NOPK)                                           OPLUS.121
       S6(I,1)=S6(I,1)*F(I,NOPP1K)                                         OPLUS.122
       S7(I,1)=F(I,NOPP2K)*(F(I,NTEP2K)+F(I,NTIP2K))                       OPLUS.123
      ENDDO                                                                OPLUS.124
C     ****                                                                 OPLUS.125
C     ****      S1 = (B(H).DEL(H))*2.*TP*N(O+)    (J-1)                    OPLUS.126
C     ****      S2 = (B(H).DEL(H))*2.*TP*N(O+)      (J)                    OPLUS.127
C     ****      S3 = (B(H).DEL(H))*2.*TP*N(O+)    (J+1)                    OPLUS.128
C     ****                                                                 OPLUS.129
      CALL BDOTDH(S3,S4,S5,J-1,S1)                                         OPLUS.130
      CALL BDOTDH(S4,S5,S6,J,S2)                                           OPLUS.131
      CALL BDOTDH(S5,S6,S7,J+1,S3)                                         OPLUS.132
C     ****                                                                 OPLUS.133
C     ****      S1 = S1*D(J-1), S2 = S2*D(J), S3 = S3*D(J+1)               OPLUS.134
C     ****                                                                 OPLUS.135
      DO I=1,LEN2                                                          OPLUS.136
       S1(I,1)=S1(I,1)*S13(I,1)                                            OPLUS.137
       S2(I,1)=S2(I,1)*S14(I,1)                                            OPLUS.138
       S3(I,1)=S3(I,1)*S15(I,1)                                            OPLUS.139
      ENDDO                                                                OPLUS.140
C     ****                                                                 OPLUS.141
C     ****      S8 = (B(H).DEL(H))*D*(B(H).DEL(H))*2.*TP*N(O+)   (J)       OPLUS.142
C     ****                                                                 OPLUS.143
      CALL BDOTDH(S1,S2,S3,J,S8)                                           OPLUS.144
C     ****                                                                 OPLUS.145
C     ****      S7 = (BZ*D/(H*DZ)+DIV(*B))*S2                              OPLUS.146
C     ****                                                                 OPLUS.147
      CALL BDZDVB(S2,T1,S11,J,S7)                                          OPLUS.148
C     ****                                                                 OPLUS.149
C     ****      COLLECT NEW EXPLICIT TERMS IN S4                           OPLUS.150
C     ****        ( RHS OF TRIDIAGONALSYSTEM )                             OPLUS.151
C     ****                                                                 OPLUS.152
      DO I=1,LEN2                                                          OPLUS.153
       S4(I,1)=-EXPLIC*(S7(I,1)+S8(I,1)+S9(I,1))                           OPLUS.154
      ENDDO                                                                OPLUS.155
C     ****                                                                 OPLUS.156
C     ****      S9 = H(J-1), S10 = H(J), S11 = H(J+1)                      OPLUS.157
C     ****                                                                 OPLUS.158
      DO I=1,LEN2                                                          OPLUS.159
       S9(I,1)=S10(I,1)                                                    OPLUS.160
       S10(I,1)=S11(I,1)                                                   OPLUS.161
       S11(I,1)=S12(I,1)                                                   OPLUS.162
      ENDDO                                                                OPLUS.163
C     ****                                                                 OPLUS.151
C     ****      S6 = (B.U)*N(O+)    (J-1)                                  OPLUS.152
C     ****      S7 = (B.U)*N(O+)      (J)                                  OPLUS.153
C     ****      S8 = (B.U)*N(O+)    (J+1)                                  OPLUS.154
C     ****                                                                 OPLUS.155
      NUK=NJM1+NU-1                                                        OPLUS.156
      NVK=NJM1+NV-1                                                        OPLUS.157
      NWK=NJM1+NW-1                                                        OPLUS.158
      NOPK=NJM1+NOP-1                                                      OPLUS.159
      DO K=1,KMAX                                                          OPLUS.160
       NUK=NUK+1                                                           OPLUS.161
       NVK=NVK+1                                                           OPLUS.162
       NWK=NWK+1                                                           OPLUS.163
       NOPK=NOPK+1                                                         OPLUS.164
       DO I=1,LEN1                                                         OPLUS.165
        S6(I,K)=(BX(I,J-1)*F(I,NUK)+BY(I,J-1)*F(I,NVK)+S9(I,K)*            OPLUS.166
     1          BZ(I,J-1)*.5*(F(I,NWK)+F(I,NWK+1)))*F(I,NOPK)              OPLUS.167
       ENDDO                                                               OPLUS.168
      ENDDO                                                                OPLUS.169
      NUK=NJ+NU-1                                                          OPLUS.170
      NVK=NJ+NV-1                                                          OPLUS.171
      NWK=NJ+NW-1                                                          OPLUS.172
      NOPK=NJ+NOP-1                                                        OPLUS.173
      DO K=1,KMAX                                                          OPLUS.174
       NUK=NUK+1                                                           OPLUS.175
       NVK=NVK+1                                                           OPLUS.176
       NWK=NWK+1                                                           OPLUS.177
       NOPK=NOPK+1                                                         OPLUS.178
       DO I=1,LEN1                                                         OPLUS.179
        S7(I,K)=(BX(I,J)*F(I,NUK)+BY(I,J)*F(I,NVK)+S10(I,K)*               OPLUS.180
     1          BZ(I,J)*.5*(F(I,NWK)+F(I,NWK+1)))*F(I,NOPK)                OPLUS.181
       ENDDO                                                               OPLUS.182
      ENDDO                                                                OPLUS.183
      NUK=NJP1+NU-1                                                        OPLUS.184
      NVK=NJP1+NV-1                                                        OPLUS.185
      NWK=NJP1+NW-1                                                        OPLUS.186
      NOPK=NJP1+NOP-1                                                      OPLUS.187
      DO K=1,KMAX                                                          OPLUS.188
       NUK=NUK+1                                                           OPLUS.189
       NVK=NVK+1                                                           OPLUS.190
       NWK=NWK+1                                                           OPLUS.191
       NOPK=NOPK+1                                                         OPLUS.192
       DO I=1,LEN1                                                         OPLUS.193
        S8(I,K)=(BX(I,J+1)*F(I,NUK)+BY(I,J+1)*F(I,NVK)+S11(I,K)*           OPLUS.194
     1          BZ(I,J+1)*.5*(F(I,NWK)+F(I,NWK+1)))*F(I,NOPK)              OPLUS.195
       ENDDO                                                               OPLUS.196
      ENDDO                                                                OPLUS.197
C     ****                                                                 OPLUS.198
C     ****     NOW ADD TERMS TO F IN S4                                    OPLUS.199
C     ****                                                                 OPLUS.200
      NOPMK=NJM1+NOP-1                                                     OPLUS.201
      NOPK=NJ+NOP-1                                                        OPLUS.202
      NOPPK=NJP1+NOP-1                                                     OPLUS.203
      NUIK=NUI-1                                                           OPLUS.204
      NVIK=NVI-1                                                           OPLUS.205
      DO K=1,KMAX                                                          OPLUS.206
       NOPMK=NOPMK+1                                                       OPLUS.207
       NOPK=NOPK+1                                                         OPLUS.208
       NOPPK=NOPPK+1                                                       OPLUS.209
       NUIK=NUIK+1                                                         OPLUS.210
       NVIK=NVIK+1                                                         OPLUS.211
       DO I=3,IMAXP2                                                       OPLUS.212
        S4(I,K)=S4(I,K)+1./(2.*C(51))*(1/(CS(J)*C(1))*(BX(I,J)*            OPLUS.213
     1          (S7(I+1,K)-S7(I-1,K))+.5*(F(I,NUIK)+F(I,NUIK+1))*          OPLUS.214
     2          BMOD(I,J)**2*(F(I+1,NOPK)/BMOD(I+1,J)**2-F(I-1,NOPK)/      OPLUS.215
     3          BMOD(I-1,J)**2))+1./C(2)*(BY(I,J)*(S8(I,K)-S6(I,K))+       OPLUS.216
     4          .5*(F(I,NVIK)+F(I,NVIK+1))*BMOD(I,J)**2*(F(I,NOPPK)/       OPLUS.217
     5          BMOD(I,J+1)**2-F(I,NOPMK)/BMOD(I,J-1)**2)))                OPLUS.218
       ENDDO                                                               OPLUS.219
      ENDDO                                                                OPLUS.220
C     ****                                                                 OPLUS.221
C     ****     PERIODIC POINTS                                             OPLUS.222
C     ****                                                                 OPLUS.223
      DO I=1,2                                                             OPLUS.224
       DO K=1,KMAX                                                         OPLUS.225
        S4(I,K)=S4(I+IMAX,K)                                               OPLUS.226
        S4(I+IMAXP2,K)=S4(I+2,K)                                           OPLUS.227
       ENDDO                                                               OPLUS.228
      ENDDO                                                                OPLUS.229
C     ****                                                                 OPLUS.230
C     ****     T1 = DIV(B)/BZ                                              OPLUS.231
C     ****                                                                 OPLUS.232
      DO I=1,LEN1                                                          OPLUS.233
       T1(I)=T1(I)/BZ(I,J)                                                 OPLUS.234
      ENDDO                                                                OPLUS.235
C     ****                                                                 OPLUS.245
C     ****      S7=D(J-1), S8=D(J), S9=D(J+1)                              OPLUS.246
C     ****                                                                 OPLUS.247
      DO I=1,LEN2                                                          OPLUS.248
       S7(I,1)=S13(I,1)                                                    OPLUS.249
       S8(I,1)=S14(I,1)                                                    OPLUS.250
       S9(I,1)=S15(I,1)                                                    OPLUS.251
      ENDDO                                                                OPLUS.252
C     ****                                                                 OPLUS.236
C     ****     S15 = 1./(H*DZ),      S14 = TP = .5*(TI+TE)                 OPLUS.237
C     ****                                                                 OPLUS.238
      NTIK=NJ+NTI                                                          OPLUS.256
      NTEK=NJ+NTE                                                          OPLUS.257
      DO I=1,LEN2                                                          OPLUS.239
       S15(I,1)=1./(S10(I,1)*C(3))                                         OPLUS.240
       S14(I,1)=.5*(F(I,NTIK)+F(I,NTEK))                                   OPLUS.241
      ENDDO                                                                OPLUS.242
C     ****                                                                 OPLUS.243
C     ****     S13 = 2.*TP/(H(-)*DZ)+GMR     (K = 1,KMAXP1)                OPLUS.244
C     ****     S12 = 2.*TP/(H(+)*DZ)-GMR     (K = 0,KMAX)                  OPLUS.245
C     ****                                                                 OPLUS.246
C     ****     GMR = G*M(0+)/(2.*R)                                        OPLUS.247
      GMR=C(54)*RMOP/(2.*C(57))                                            OPLUS.248
      DO I=1,LEN2-LEN1                                                     OPLUS.249
       S13(I,2)=2.*S14(I,2)*(.5*(S15(I,1)+S15(I,2)))+GMR                   OPLUS.250
       S12(I,2)=2.*S14(I,1)*(.5*(S15(I,1)+S15(I,2)))-GMR                   OPLUS.251
      ENDDO                                                                OPLUS.252
C     ****                                                                 OPLUS.253
C     ****     UPPER AND LOWER BOUNDARIES                                  OPLUS.254
C     ****                                                                 OPLUS.255
      DO I=1,LEN1                                                          OPLUS.256
       S13(I,1)=2.*S14(I,1)*(1.5*S15(I,1)-0.5*S15(I,2))+GMR                OPLUS.257
       S13(I,KMAXP1)=2.*(2.*S14(I,KMAX)-S14(I,KMAXM1))*(1.5*S15(I,KMAX)    OPLUS.258
     1               -0.5*S15(I,KMAXM1))+GMR                               OPLUS.259
       S12(I,1)=2.*(2.*S14(I,1)-S14(I,2))*(1.5*S15(I,1)-0.5*S15(I,2))      OPLUS.260
     1          -GMR                                                       OPLUS.261
       S12(I,KMAXP1)=2.*S14(I,KMAX)*(1.5*S15(I,KMAX)-0.5*S15(I,KMAXM1))    OPLUS.262
     1               -GMR                                                  OPLUS.263
      ENDDO                                                                OPLUS.264
C     ****                                                                 OPLUS.265
C     ****     S11 = D(K+1/2)                                              OPLUS.266
C     ****                                                                 OPLUS.267
      DO I=1,LEN2-LEN1                                                     OPLUS.268
       S11(I,2)=.5*(S8(I,1)+S8(I,2))                                       OPLUS.269
      ENDDO                                                                OPLUS.270
C     ****                                                                 OPLUS.271
C     ****     UPPER AND LOWER BOUNDARIES                                  OPLUS.272
C     ****                                                                 OPLUS.273
      DO I=1,LEN1                                                          OPLUS.274
       S11(I,1)=(1.5*S8(I,1)-0.5*S8(I,2))                                  OPLUS.275
       S11(I,KMAXP1)=(1.5*S8(I,KMAX)-.5*S8(I,KMAXM1))                      OPLUS.276
      ENDDO                                                                OPLUS.277
C     ****                                                                 OPLUS.278
C     ****      S7 = (DIV(B)+(DH*D*BZ)/(D*BZ)                              OPLUS.279
C     ****                                                                 OPLUS.280
C     ****      PERIODIC POINTS                                            OPLUS.281
C     ****                                                                 OPLUS.282
      DO I=1,2                                                             OPLUS.283
       DO K=1,3*KMAXP1                                                     OPLUS.284
        S9(I,K)=S9(I+IMAX,K)                                               OPLUS.285
        S9(I+IMAXP2,K)=S9(I+2,K)                                           OPLUS.288
       ENDDO                                                               OPLUS.191
      ENDDO                                                                OPLUS.292
      DO K=1,KMAX                                                          OPLUS.293
       DO I=3,IMAXP2                                                       OPLUS.294
        S7(I,K)=T1(I)+1./(C(51)*S8(I,K)*BZ(I,J)**2)*(BX(I,J)/CS(J)         OPLUS.295
     1          *(S8(I+1,K)*BZ(I+1,J)-S8(I-1,K)*BZ(I-1,J))/(2.*C(1))       OPLUS.296
     2          +BY(I,J)*(S9(I,K)*BZ(I,J+1)-S7(I,K)*BZ(I,J-1))             OPLUS.297
     3          /(2.*C(2)))                                                OPLUS.298
       ENDDO                                                               OPLUS.299
      ENDDO                                                                OPLUS.300
C     ****                                                                 OPLUS.301
C     ****      PERIODIC POINTS                                            OPLUS.302
C     ****                                                                 OPLUS.303
      DO I=1,2                                                             OPLUS.304
       DO K=1,KMAXP1                                                       OPLUS.305
        S7(I,K)=S7(I+IMAX,K)                                               OPLUS.306
        S7(I+IMAXP2,K)=S7(I+2,K)                                           OPLUS.307
       ENDDO                                                               OPLUS.308
      ENDDO                                                                OPLUS.309
C     ****                                                                 OPLUS.310
C     ****     S10 = (1./(H*DZ)-(DIV(B)+DH*D*BZ/(D*BZ))/(2*BZ))*BZ**2      OPLUS.311
C     ****     S9 = (1./(H*DZ)+(DIV(B)+DH*D*BZ/(D*BZ))/(2*BZ))*BZ**2       OPLUS.312
C     ****                                                                 OPLUS.313
      DO K=1,KMAX                                                          OPLUS.314
       DO I=1,LEN1                                                         OPLUS.315
        S10(I,K)=(S15(I,K)-.5*S7(I,K))*BZ(I,J)**2                          OPLUS.316
        S9(I,K)=(S15(I,K)+.5*S7(I,K))*BZ(I,J)**2                           OPLUS.317
       ENDDO                                                               OPLUS.318
      ENDDO                                                                OPLUS.319
C     ****                                                                 OPLUS.320
C     ****     SHAPIRO SMOOTHER                                            OPLUS.321
C     ****     SET S4 TO N(O+)/(2*DT)  (N-1)                               OPLUS.322
C     ****                                                                 OPLUS.323
      NOJP2K=NJP2+NOPNM                                                    OPLUS.324
      NOJP1K=NJP1+NOPNM                                                    OPLUS.325
      NOJNMK=NJ+NOPNM                                                      OPLUS.326
      NOJM1K=NJM1+NOPNM                                                    OPLUS.327
      NOJM2K=NJM2+NOPNM                                                    OPLUS.328
      C26=0.09
      DO I=1,LEN2                                                          OPLUS.329
       S1(I,1)=F(I,NOJNMK)-C26*(F(I,NOJP2K)+F(I,NOJM2K)-4.*                OPLUS.330
     1         (F(I,NOJP1K)+F(I,NOJM1K))+6.*F(I,NOJNMK))                   OPLUS.331
      ENDDO                                                                OPLUS.332
      DO I=3,LEN2-2                                                        OPLUS.333
       S4(I,1)=S4(I,1)-(S1(I,1)-C26*(S1(I+2,1)+S1(I-2,1)-4.*               OPLUS.334
     1         (S1(I+1,1)+S1(I-1,1))+6.*S1(I,1)))*C(7)                     OPLUS.335
      ENDDO                                                                OPLUS.336
C     ****                                                                 OPLUS.337
C     ****     BEGIN COEFFS P,Q,R IN S1,S2,S3                              OPLUS.338
C     ****                                                                 OPLUS.339
      DO I=1,LEN2                                                          OPLUS.340
       S1(I,1)=S10(I,1)*S11(I,1)*S12(I,1)                                  OPLUS.341
       S2(I,1)=-(S9(I,1)*S11(I,2)*S12(I,2)+S10(I,1)*S11(I,1)*S13(I,1))     OPLUS.342
       S3(I,1)=S9(I,1)*S11(I,2)*S13(I,2)                                   OPLUS.343
      ENDDO                                                                OPLUS.344
C     ****                                                                 OPLUS.345
C     ****     S7 = (B.U)                                                  OPLUS.346
C     ****                                                                 OPLUS.347
      DO I=1,LEN2                                                          OPLUS.357
C      ****                                                                OPLUS.345
C      ****     S6 = H                                                     OPLUS.358
C      ****                                                                OPLUS.345
       S6(I,1)=1/(S15(I,1)*C(3))                                           OPLUS.359
      ENDDO                                                                OPLUS.360
      NUK=NJ+NU-1                                                          OPLUS.348
      NVK=NJ+NV-1                                                          OPLUS.349
      NWK=NJ+NW-1                                                          OPLUS.350
      DO K=1,KMAX                                                          OPLUS.351
       NUK=NUK+1                                                           OPLUS.352
       NVK=NVK+1                                                           OPLUS.353
       NWK=NWK+1                                                           OPLUS.354
       DO I=1,LEN1                                                         OPLUS.355
       S7(I,K)=BX(I,J)*F(I,NUK)+BY(I,J)*F(I,NVK)+S6(I,K)*BZ(I,J)*.5*       OPLUS.356
     1          (F(I,NWK)+F(I,NWK+1))                                      OPLUS.357
       ENDDO                                                               OPLUS.358
      ENDDO                                                                OPLUS.359
C     ****                                                                 OPLUS.360
C     ****     FINISH P AND R IN S1 AND S3                                 OPLUS.361
C     ****                                                                 OPLUS.362
      NWIK=NWI-1                                                           OPLUS.363
      DO K=1,KMAXM1                                                        OPLUS.364
       NWIK=NWIK+1                                                         OPLUS.365
       DO I=1,LEN1                                                         OPLUS.366
        S1(I,K+1)=S1(I,K+1)+(BZ(I,J)*S7(I,K)+                              OPLUS.367
     1           .5*(F(I,NWIK+1)+F(I,NWIK+2)))*.5*S15(I,K+1)               OPLUS.368
        S2(I,K)=S2(I,K)-.5*(F(I,NWIK)+F(I,NWIK+1))*6./C(51)                OPLUS.369
        S3(I,K)=S3(I,K)-(BZ(I,J)*S7(I,K+1)+.5*(F(I,NWIK)+F(I,NWIK+1)))*    OPLUS.370
     1          .5*S15(I,K)                                                OPLUS.371
       ENDDO                                                               OPLUS.372
      ENDDO                                                                OPLUS.373
C     ****                                                                 OPLUS.374
C     ****     UPPER AND LOWER BOUNDARIES                                  OPLUS.375
C     ****                                                                 OPLUS.376
      NWIK=NWI                                                             OPLUS.377
      DO I=1,LEN1                                                          OPLUS.378
      S1(I,1)=S1(I,1)+(BZ(I,J)*(2.*S7(I,1)-S7(I,2))+.5*(F(I,NWIK)+         OPLUS.379
     1        F(I,NWIK+1)))*.5*S15(I,1)                                    OPLUS.380
      S2(I,KMAX)=S2(I,KMAX)-.5*(F(I,NWIK+KMAX)+F(I,NWIK+KMAXM1))*6./       OPLUS.381
     A            C(51)                                                    OPLUS.382
      S3(I,KMAX)=S3(I,KMAX)-(BZ(I,J)*(2.*S7(I,KMAX)-S7(I,KMAXM1))+.5*      OPLUS.383
     1          (F(I,NWIK+KMAX)+F(I,NWIK+KMAXM1)))*.5*S15(I,KMAX)          OPLUS.384
      ENDDO                                                                OPLUS.385
C     ****                                                                 OPLUS.386
C     ****     ADDITIONS TO Q IN S2                                        OPLUS.387
C     ****                                                                 OPLUS.388
      DO K=1,KMAX                                                          OPLUS.389
       DO I=1,LEN1                                                         OPLUS.390
        S2(I,K)=S2(I,K)-S7(I,K)*T1(I)*BZ(I,J)-C(7)                         OPLUS.391
       ENDDO                                                               OPLUS.392
      ENDDO                                                                OPLUS.393
C     ****                                                                 OPLUS.394
C     ****     UPPER BOUNDARY CONDITION                                    OPLUS.395
C     ****                                                                 OPLUS.396
C     ****     T2 = A, T3= B                                               OPLUS.397
      NWIK=NWI+KMAX                                                        OPLUS.398
      DO I=1,LEN1                                                          OPLUS.399
C      ****                                                                OPLUS.400
C      ****     MODS FOR OPLUS -- UPPER BOUNDARY CONDITION                 OPLUS.401
C      ****                                                                OPLUS.402
       T2(I) = 0.                                                          OPLUS.405
       T3(I) = -BZ(I,J)**2*S11(I,KMAXP1)*S12(I,KMAXP1)-T2(I)               OPLUS.408
       T2(I) = -BZ(I,J)**2*S11(I,KMAXP1)*S13(I,KMAXP1)+T2(I)               OPLUS.409
C      ****                                                                OPLUS.410
C      ****     S2 = Q = Q+B/A*R                                           OPLUS.411
C      ****                                                                OPLUS.412
       S2(I,KMAX)=S2(I,KMAX)+T3(I)/T2(I)*S3(I,KMAX)                        OPLUS.413
C      ****                                                                OPLUS.414
C      ****     S4 = F = F -R/A*PHI                                        OPLUS.415
C      ****                                                                OPLUS.416
       S4(I,KMAX)=S4(I,KMAX)-T7(I)*S3(I,KMAX)/T2(I)                        OPLUS.417
       S3(I,KMAX)=0.                                                       OPLUS.418
      ENDDO                                                                OPLUS.419
C     ****                                                                 OPLUS.420
C     ****     SOURCES AND SINKS                                           OPLUS.421
C     ****                                                                 OPLUS.422
      NTK=NJ+NT-1                                                          OPLUS.423
      NMSK=NJ+NMS-1                                                        OPLUS.424
      DO K=1,KMAX                                                          OPLUS.425
       NTK=NTK+1                                                           OPLUS.426
       NMSK=NMSK+1                                                         OPLUS.427
       DO I=1,LEN1                                                         OPLUS.428
       XNEU(I,K)=C(81)*EXPS(K)*.5*(F(I,NMSK)+F(I,NMSK+1))/                 OPLUS.429
     1           (C(84)*F(I,NTK))                                          OPLUS.430
       ENDDO                                                               OPLUS.431
      ENDDO                                                                OPLUS.432
      NPS1K=NJ+NPS-1                                                       OPLUS.433
      NPS2K=NJ+NPS2-1                                                      OPLUS.434
      NPN2DK=NJ+NPN2D-1                                                    OPLUS.435
      NEK=NJ+NE-1                                                          OPLUS.436
      NOPK=NJ+NOP-1                                                        OPLUS.437
      DO K=1,KMAX                                                          OPLUS.438
       NPS1K=NPS1K+1                                                       OPLUS.439
       NPS2K=NPS2K+1                                                       OPLUS.440
       NPN2DK=NPN2DK+1                                                     OPLUS.441
       NEK=NEK+1                                                           OPLUS.442
       NOPK=NOPK+1                                                         OPLUS.443
       DO I=1,LEN1                                                         OPLUS.444
C       ****                                                               OPLUS.445
C       ****     CALCULATE LOSS AND SUBSTRACT FROM S2                      OPLUS.446
C       ****                                                               OPLUS.447
        XIOP2P(I,K)=.5*(QOP2P(I,K)+QOP2P(I,K+1))/(XNEU(I,K)*               OPLUS.448
     1              ((RK16(I,K)+RK17(I,K))*(1.-F(I,NPS1K)-F(I,NPS2K))/     OPLUS.449
     2              RMASS(3)+RK18(I,K)*F(I,NPS2K)/RMASS(2))+               OPLUS.450
     3              (RK19(I,K)+RK20(I,K))*F(I,NEK)+RK21(I,K)+RK22(I,K))    OPLUS.451
        XIOP2D(I,K)=(.5*(QOP2D(I,K)+QOP2D(I,K+1))+(RK20(I,K)*F(I,NEK)+     OPLUS.452
     1              RK22(I,K))*XIOP2P(I,K))/(XNEU(I,K)*                    OPLUS.453
     2              (RK23(I,K)*(1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3)+        OPLUS.454
     3              RK24(I,K)*F(I,NPS2K)/RMASS(2)+                         OPLUS.455
     4              RK26(I,K)*F(I,NPS1K)/RMASS(1))+                        OPLUS.456
     5              RK25(I,K)*F(I,NEK)+RK27(I,K))                          OPLUS.457
        S13(I,K)=XNEU(I,K)*(RK1(I,K,1)*F(I,NPS1K)/RMASS(1)+                OPLUS.458
     2           RK2(I,K)*(1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3)+             OPLUS.459
     3           RK10(I,K)*F(I,NPN2DK)/RMN2D)                              OPLUS.460
        S2(I,K)=S2(I,K)-S13(I,K)                                           OPLUS.461
       ENDDO                                                               OPLUS.462
      ENDDO                                                                OPLUS.463
C     ****                                                                 OPLUS.464
C     ****     ADD SOURCE TERM TO RHS (F) IN S4                            OPLUS.465
C     ****                                                                 OPLUS.466
      NQOPK=NQOP-1                                                         OPLUS.467
      NEK=NJ+NE-1                                                          OPLUS.468
      NPS2K=NJ+NPS2-1                                                      OPLUS.469
      DO K=1,KMAX                                                          OPLUS.470
       NQOPK=NQOPK+1                                                       OPLUS.471
       NEK=NEK+1                                                           OPLUS.472
       NPS2K=NPS2K+1                                                       OPLUS.473
       DO I=1,LEN1                                                         OPLUS.474
c        if(j.eq.28)write(6,*)S4(I,K),F(I,NQOPK),XIOP2P(I,K),XIOP2D(I,K),
c     1            i,k
        S4(I,K)=S4(I,K)-.5*(F(I,NQOPK)+F(I,NQOPK+1))-(RK19(I,K)*           OPLUS.475
     1          F(I,NEK)+RK21(I,K))*XIOP2P(I,K)-(RK25(I,K)*                OPLUS.476
     2          F(I,NEK)+RK27(I,K))*XIOP2D(I,K)-(RK18(I,K)*                OPLUS.477
     3          XIOP2P(I,K)+RK24(I,K)*XIOP2D(I,K))*F(I,NPS2K)/             OPLUS.478
     4          RMASS(2)*XNEU(I,K)                                         OPLUS.479
       ENDDO                                                               OPLUS.480
      ENDDO                                                                OPLUS.481
C     ****                                                                 OPLUS.482
C     ****     LOWER BOUNDARY CONDITION                                    OPLUS.483
C     ****                                                                 OPLUS.484
C     ****     N(O+) = Q/L                                                 OPLUS.485
      NQOPK=NQOP                                                           OPLUS.486
      DO I=1,LEN1                                                          OPLUS.487
       S2(I,1)=S2(I,1)-S1(I,1)                                             OPLUS.488
       S4(I,1)=S4(I,1)-2.*S1(I,1)*F(I,NQOPK)/(1.5*S13(I,1)-.5*S13(I,2))    OPLUS.489
       S1(I,1)=0.                                                          OPLUS.490
      ENDDO                                                                OPLUS.491
c        if(j.eq.28)pause
C     ****                                                                 OPLUS.492
C     ****     SOLVE TRIDIAGONAL SYSTEM                                    OPLUS.493
C     ****                                                                 OPLUS.494
      NOPK=NJNP+NOP                                                        OPLUS.495
      CALL TRSOLV(S1,S2,S3,S4,S7,F(1,NOPK),LEN1,3,LEN1-2,KMAXP1,1,KMAX,    OPLUS.496
     11)                                                                   OPLUS.497
C     ****                                                                 OPLUS.498
C     ****     FILTER N(O+)                                                OPLUS.499
C     ****                                                                 OPLUS.500
      IF(KUTT(J).LT.IMAXH)THEN                                             OPLUS.501
       NOPK=NJNP+NOP                                                       OPLUS.502
       CALL FILTER2(NOPK,KMAX,KUTT(J))                                     OPLUS.503
      ENDIF                                                                OPLUS.504
C     ****                                                                 OPLUS.505
C     ****     TIME SMOOTHING                                              OPLUS.506
C     ****                                                                 OPLUS.507
      NOPNMK=NJ+NOPNM                                                      OPLUS.508
      NOPK=NJ+NOP                                                          OPLUS.509
      NOPNPK=NJNP+NOP                                                      OPLUS.510
      NOPMNK=NJNP+NOPNM                                                    OPLUS.511
      DO I=1,LEN2                                                          OPLUS.512
       F(I,NOPMNK)=C(30)*F(I,NOPK)+C(31)*(F(I,NOPNMK)+F(I,NOPNPK))         OPLUS.513
      ENDDO                                                                OPLUS.514
C     ****                                                                 OPLUS.515
C     ****     PERIODIC POINTS                                             OPLUS.516
C     ****                                                                 OPLUS.517
      K1=NJNP+NOP                                                          OPLUS.518
      K2=K1+KMAXM1                                                         OPLUS.519
      DO N=1,2                                                             OPLUS.520
       DO I=1,2                                                            OPLUS.521
        DO K=K1,K2                                                         OPLUS.522
         F(I,K)=F(I+IMAX,K)                                                OPLUS.523
         F(I+IMAXP2,K)=F(I+2,K)                                            OPLUS.524
        ENDDO                                                              OPLUS.525
       ENDDO                                                               OPLUS.526
       K1=NJNP+NOPNM                                                       OPLUS.527
       K2=K1+KMAXM1                                                        OPLUS.528
      ENDDO                                                                OPLUS.529
C     ****                                                                 OPLUS.530
C     ****     INSURE NON-NEGATIVE N(O+)                                   OPLUS.531
C     ****                                                                 OPLUS.532
      NOPK=NJNP+NOP                                                        OPLUS.533
      NOPNMK=NJNP+NOPNM                                                    OPLUS.534
      DO I=1,LEN2                                                          OPLUS.535
       IF((F(I,NOPK)-1.D-5).LT.0.)F(I,NOPK)=1.D-5                          OPLUS.536
       IF((F(I,NOPNMK)-1.D-5).LT.0.)F(I,NOPNMK)=1.D-5                      OPLUS.537
      ENDDO                                                                OPLUS.538
      RETURN                                                               OPLUS.539
      END                                                                  OPLUS.540
C                                                                          OPLUS.541
*DK ORORA                                                                  ORORA.1
      SUBROUTINE ORORA                                                     ORORA.2
C     ****                                                                 ORORA.3
C     ****     CALCULATES AURORAL ADDITIONS TO IONIZATION RATES            ORORA.4
C     ****     ON ENTRY:                                                   ORORA.5
C     ****     T3=DRIZL                 (PROFILE FOR AURORAL DRIZZLE)      ORORA.6
C     ****     T5=CUSP                  (PROFILE FOR AURORAL CUSP)         ORORA.7
C     ****     T6,T7=ALFA(1), ALFA(2)   (CHARACTERISTIC PARTICLE ENERGIE   ORORA.8
C     ****     T8,T9=F(1),F(2)          (PARTICLE FLUXES)                  ORORA.9
C     ****                                                                 ORORA.10
      INCLUDE 'param.h'                                                    ORORA.11
      INCLUDE 'vscrw.h'                                                    ORORA.12
      INCLUDE 'const.h'                                                    ORORA.13
      INCLUDE 'index.h'                                                    ORORA.14
      INCLUDE 'buffe.h'                                                    ORORA.15
      INCLUDE 'phycs.h'                                                    ORORA.16
      COMMON /OVALR/ RRAD(2),H0,RH,RROTH,E0,REE,RROTE,FC,ALFAC,FD,ALFAD    ORORA.17
     1, ALFK,ALF6,ALF21,RROT6,RROT21,RD6,RD6V,RD21,RH6,RH21,RT6,RT21       ORORA.18
     2, ALFA0,RALFA,ALFA20,RALFA2,E20,RE2                                  ORORA.19
C     ****                                                                 ORORA.20
C     ****     NO CALCULATION IF ISHUNK=0                                  ORORA.21
C     ****                                                                 ORORA.22
      IF(ISHUNK.EQ.0)RETURN                                                ORORA.23
C     ****                                                                 ORORA.24
C     ****     CALCULATE TOTAL IONIZATION, QI                              ORORA.25
C     ****                                                                 ORORA.26
c      do i=1,len1
c       write(6,*)T3(I),T5(I),T6(I),T7(I),i
c      enddo
c      pause
      DO K=1,KMAX                                                          ORORA.27
       DO I=1,LEN1                                                         ORORA.28
C       ****                                                               ORORA.29
C       ****     S7,S8=X(1),X(2)  (AURORA)                                 ORORA.30
C       ****     S9=X  (CUSP)                                              ORORA.31
C       ****     S10=X  (DRIZZLE)                                          ORORA.32
C       ****     WHERE X=(N/4.D-6)**0.606/ALFA                             ORORA.33
C       ****     AND   N=P0*EXP(-Z)/G                                      ORORA.34
C       ****                                                               ORORA.35
        S6(I,K)=(C(81)*EXPS(K)/(C(54)*4.D-6))**0.606                       ORORA.36
        S7(I,K)=S6(I,K)/T6(I)                                              ORORA.37
        S8(I,K)=S6(I,K)/T7(I)                                              ORORA.38
c        S7(I,K)=0.5d0*S6(I,K)/T6(I)                                       ORORA.37
c        S8(I,K)=0.5d0*S6(I,K)/T7(I)                                       ORORA.38
        S9(I,K)=S6(I,K)/ALFAC                                              ORORA.39
        S10(I,K)=S6(I,K)/ALFAD                                             ORORA.40
       ENDDO                                                               ORORA.41
      ENDDO                                                                ORORA.42
C     ****                                                                 ORORA.43
C     ****     S3,S4 = F(X(1)),F(X(2)) (AURORA)                            ORORA.44
C     ****     S5 = F(X) (CUSP)                                            ORORA.45
C     ****     S6 = F(X) (DRIZZLE)                                         ORORA.46
C     ****                                                                 ORORA.47
      CALL AION(S7,S3,LEN2)                                                ORORA.48
      CALL AION(S8,S4,LEN2)                                                ORORA.49
      CALL AION(S9,S5,LEN2)                                                ORORA.50
      CALL AION(S10,S6,LEN2)                                               ORORA.51
      DO K=1,KMAX                                                          ORORA.52
       DO I=1,LEN1                                                         ORORA.53
C       ****                                                               ORORA.54
C       ****     S7,S8=ALFA(1)*F(1),ALFA(2)*F(2) (AURORA)                  ORORA.55
C       ****     S9=ALFA*F (CUSP)                                          ORORA.56
C       ****     S10=ALFA*F (DRIZZLE)                                      ORORA.57
C       ****                                                               ORORA.58
        S7(I,K)=T6(I)*T8(I)                                                ORORA.59
        S8(I,K)=T7(I)*T9(I)                                                ORORA.60
        S9(I,K)=T5(I)*ALFAC*FC                                             ORORA.61
        S10(I,K)=T3(I)*ALFAD*FD                                            ORORA.62
       ENDDO                                                               ORORA.63
      ENDDO                                                                ORORA.64
      NMSK=NJ+NMS                                                          ORORA.65
      NPS1K=NJ+NPS                                                         ORORA.66
      NPS2K=NJ+NPS2                                                        ORORA.67
      NTK=NJ+NT                                                            ORORA.68
      DO I=1,LEN2                                                          ORORA.69
C      ****                                                                ORORA.70
C      ****     S1=SUM(QI)=QT                                              ORORA.71
C      ****       =SUM(F*ALFA*FX(X)/(35.D-3*H))                            ORORA.72
C      ****                                                                ORORA.73
       S11(I,1)=C(54)*.5*(F(I,NMSK)+F(I,NMSK+1))/(35.D-3*C(57)*F(I,NTK))   ORORA.74
       S1(I,1)=(S7(I,1)*S3(I,1)+S8(I,1)*S4(I,1)+S9(I,1)*S5(I,1)+S10(I,1)   ORORA.75
     1         *S6(I,1))*S11(I,1)                                          ORORA.76
C      ****                                                                ORORA.77
C      ****     S3=DENOM=0.92*PS3/RMASS(3)+1.5*PS1/RMASS(1)+0.56*PS2/      ORORA.78
C      ****     RMASS(2)                                                   ORORA.79
C      ****                                                                ORORA.80
       S3(I,1)=0.92*(1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3)+1.5*F(I,NPS1K)/    ORORA.81
     1         RMASS(1)+0.56*F(I,NPS2K)/RMASS(2)                           ORORA.82
      ENDDO                                                                ORORA.83
C     ****                                                                 ORORA.84
C     ****      ADD IONIZATION CONTRIBUTIONS TO NQO2P, NQOP, NQN2P, NQNP   ORORA.85
C     ****                                                                 ORORA.86
C     ****      S13 = QO2P, S14 = QOP, S15 = QN2P         (K+1/2)          ORORA.87
C     ****                                                                 ORORA.88
      NPS1K=NJ+NPS                                                         ORORA.89
      NPS2K=NPS1K+KMAXP1                                                   ORORA.90
      DO I=1,LEN2                                                          ORORA.91
       S13(I,1)=S1(I,1)*F(I,NPS1K)/(RMASS(1)*S3(I,1))                      ORORA.92
       S14(I,1)=S1(I,1)*(0.5*F(I,NPS1K)/RMASS(1)+                          ORORA.93
     1          0.56*F(I,NPS2K)/RMASS(2))/S3(I,1)                          ORORA.94
       IF((1-F(I,NPS1K)-F(I,NPS2K)).GE.0.)THEN                             ORORA.95
         S15(I,1)=S1(I,1)*0.7*(1.-F(I,NPS1K)-F(I,NPS2K))/                  ORORA.96
     1           (RMASS(3)*S3(I,1))                                        ORORA.97
       ELSE                                                                ORORA.98
        S15(I,1)=0.                                                        ORORA.99
       ENDIF                                                               ORORA.100
      ENDDO                                                                ORORA.104
C     ****                                                                 ORORA.105
C     ****      SET NQO2P, NQOP, NQN2P                                     ORORA.106
C     ****                                                                 ORORA.107
      NQO2PK=NQO2P                                                         ORORA.108
      NQOPK=NQOP                                                           ORORA.109
      NQN2PK=NQN2P                                                         ORORA.110
      NQNPK=NQNP                                                           ORORA.111
C     ****                                                                 ORORA.112
C     ****      LEVELS 2 THRU KMAX                                         ORORA.113
C     ****                                                                 ORORA.114
      N0=0
      DO I=LEN1+1,LEN2                                                     ORORA.115
       F(I,NQO2PK)=F(I,NQO2PK)+DSQRT(S13(I,1)*S13(I,N0))                    ORORA.116
       F(I,NQOPK)=F(I,NQOPK)+DSQRT(S14(I,1)*S14(I,N0))                      ORORA.117
       F(I,NQN2PK)=F(I,NQN2PK)+DSQRT(S15(I,1)*S15(I,N0))                    ORORA.118
       F(I,NQNPK)=F(I,NQNPK)+.22/.7*DSQRT(S15(I,1)*S15(I,N0))               ORORA.119
      ENDDO                                                                ORORA.120
C     ****                                                                 ORORA.121
C     ****      LEVELS 1 AND KMAXP1                                        ORORA.122
C     ****                                                                 ORORA.123
      DO I=1,LEN1                                                          ORORA.124
      IF(1.5*S13(I,1).GE.0.5*S13(I,2))THEN
       F(I,NQO2PK)=F(I,NQO2PK)+1.5*S13(I,1)-0.5*S13(I,2)                    ORORA.125
      ELSE
        F(I,NQO2PK)=F(I,NQO2PK)+1.*S13(I,1)
      ENDIF 
      IF(1.5*S14(I,1).GE.0.5*S14(I,2))THEN
       F(I,NQOPK)=F(I,NQOPK)+1.5*S14(I,1)-0.5*S14(I,2)                      ORORA.126
      ELSE
       F(I,NQOPK)=F(I,NQOPK)+1.*S14(I,1)
      ENDIF
      IF(1.5*S15(I,1).GE.0.5*S15(I,2))THEN
       F(I,NQN2PK)=F(I,NQN2PK)+1.5*S15(I,1)-0.5*S15(I,2)                    ORORA.127
      ELSE
       F(I,NQN2PK)=F(I,NQN2PK)+1.0*S15(I,1)
      ENDIF
      F(I,NQNPK)=F(I,NQNPK)+.22/.7*(1.5*S15(I,1)-0.5*S15(I,2))             ORORA.128
      F(I,NQO2PK+KMAX)=F(I,NQO2PK+KMAX)+1.5*S13(I,KMAX)-                   ORORA.129
     1                 0.5*S13(I,KMAX-1)                                   ORORA.130
      F(I,NQOPK+KMAX)=F(I,NQOPK+KMAX)+1.5*S14(I,KMAX)-                     ORORA.131
     1                0.5*S14(I,KMAX-1)                                    ORORA.132
      F(I,NQN2PK+KMAX)=F(I,NQN2PK+KMAX)+1.5*S15(I,KMAX)-                   ORORA.133
     1                 0.5*S15(I,KMAX-1)                                   ORORA.134
      F(I,NQNPK+KMAX)=F(I,NQNPK+KMAX)+.22/.7*(1.5*S15(I,KMAX)-             ORORA.135
     1                0.5*S15(I,KMAXM1))                                   ORORA.136
      ENDDO                                                                ORORA.137
      RETURN                                                               ORORA.138
      END                                                                  ORORA.139
C                                                                          ORORA.140
*DK POLHT                                                                  POLHT.1
      SUBROUTINE POLHT(QP,IM)                                              POLHT.2
C     ****                                                                 POLHT.3
C     ****     CALCULATES HORIZONTAL VARIATION OF POLAR CUSP HEATING       POLHT.4
C     ****                                                                 POLHT.6
      INCLUDE 'param.h'                                                    POLHT.6
      COMMON /IONCR/ ISTAR,IHEM,THETA0(2),OFFA(2),OFFC(2),DSKOFA(2),       POLHT.7
     1DSKOFC(2),PHID(2),PHIN(2),PHIDP0(2),PHIDM0(2),PHINP0(2),PHINM0(2),   POLHT.8
     2 PSIM(2),PSIE(2),PCEN(2),R1(2),COLATC(IMAXMP,JMX0),
     3 P(IMX0,JMX0),CRIT(2)                                                POLHT.9
      COMMON/ANGLE/ALON(ZIMX),COLAT(ZIMX)                                  POLHT.10
      DIMENSION QP(1)                                                      POLHT.11
      DATA S5/.08726646/,S20/.34906585/,S3/.05235988/,PI/3.1415927/        POLHT.12
C     ****                                                                 POLHT.13
C     ****    ON RECOMMENDATION OF ROD HEELIS, PLACE THE CUSP AT THE       POLHT.14
C     ****     REVERSAL BOUNDARY WITH A RADIUS OF 5 DEGREES                POLHT.15
C     ****                                                                 POLHT.16
      RAD=THETA0(IHEM)                                                     POLHT.17
      DO I=1,IM                                                            POLHT.18
       QP(I)=(DEXP(-((RAD-COLAT(I))/S5)**2)+                               POLHT.19
     1       DEXP(-((PI-RAD-COLAT(I))/S5)**2))*                            POLHT.20
     2       DEXP(-(DATAN2(DSIN(ALON(I)-PHID(IHEM)),                       POLHT.21
     3       DCOS(ALON(I)-PHID(IHEM)))/S20)**2)                            POLHT.22
      ENDDO                                                                POLHT.23
      RETURN                                                               POLHT.24
      END                                                                  POLHT.25
C                                                                          POLHT.26
*DK QINITE                                                                QINITE.1
      SUBROUTINE QINITE                                                   QINITE.2
C     ****                                                                QINITE.3
C     ****      CALCULATE BACKGROUND IONIZATION RATES                     QINITE.4
C     ****                                                                QINITE.5
      INCLUDE 'param.h'                                                   QINITE.6
      INCLUDE 'vscrw.h'                                                   QINITE.7
      INCLUDE 'const.h'                                                   QINITE.8
      INCLUDE 'index.h'                                                   QINITE.9
      INCLUDE 'buffe.h'                                                   QINITE.10
      INCLUDE 'rates.h'                                                   QINITE.11
      INCLUDE 'cpbnd.h'                                                   QINITE.11
      COMMON/MASS/ RMN4S,RMN2D,RMNO,BRN2D,CEE                             QINITE.12
      DIMENSION SA(3,3),SI(3,3),AL(3)                                     QINITE.13
      DATA                                                                QINITE.14
     1SA/1.6D-18,0.,0.,22.D-18,10.24D-18,23.11D-18,16.D-18,8.4D-18,       QINITE.15
     211.61D-18/,                                                         QINITE.16
     3SI/1.0D-18,0.,0.,22.D-18,10.24D-18,23.11D-18,16.D-18,8.4D-18,       QINITE.17
     411.61D-18/,                                                         QINITE.18
C     ****                                                                QINITE.10
C     ****    MOD FOR QINITE (COMPUTES BACKGROUND IONIZATION RATES)       QINITE.20
C     ****                                                                QINITE.21
     5AL/2.D7,2.D6,2.D6/                                                  QINITE.22
C     ****                                                                QINITE.24
C     ****      S1 = PSI1, S2 = PSI2, S3 = PSI3          (K)              QINITE.25
C     ****                                                                QINITE.26
      NPS1K= NJ+NPS                                                       QINITE.27
      NPS2K= NJ+NPS2                                                      QINITE.28
C     ****                                                                QINITE.29
C     ****      LEVELS 2 THRU KMAXP1                                      QINITE.30
C     ****                                                                QINITE.31
      DO K=2,KMAXP1                                                       QINITE.32
       DO I=1,LEN1                                                        QINITE.33
        S1(I,K)=.5*(F(I,NPS1K)+F(I,NPS1K+1))                              QINITE.34
        S2(I,K)=.5*(F(I,NPS2K)+F(I,NPS2K+1))                              QINITE.35
       ENDDO                                                              QINITE.36
       NPS1K=NPS1K+1                                                      QINITE.37
       NPS2K=NPS2K+1                                                      QINITE.38
      ENDDO                                                               QINITE.39
C     ****                                                                QINITE.40
C     ****      LEVEL 1                                                   QINITE.41
C     ****                                                                QINITE.42
      NPS1K=NJ+NPS                                                        QINITE.43
      NPS2K=NPS1K+KMAXP1                                                  QINITE.44
      DO I=1,LEN1                                                         QINITE.45
       S1(I,1)=.5*((B(I,1,1)+1.)*F(I,NPS1K)+B(I,1,2)*F(I,NPS2K)+FB(I,1))  QINITE.46
       S2(I,1)=.5*(B(I,2,1)*F(I,NPS1K)+(B(I,2,2)+1.)*F(I,NPS2K)+FB(I,2))  QINITE.47
      ENDDO                                                               QINITE.48
      DO I=1,LEN3                                                         QINITE.49
       S3(I,1)=1.-S1(I,1)-S2(I,1)                                         QINITE.50
      ENDDO                                                               QINITE.51
C     ****                                                                QINITE.52
C     ****      S4 =T                   (K)                               QINITE.53
C     ****                                                                QINITE.54
      NTK=NJ+NT                                                           QINITE.55
C     ****                                                                QINITE.56
C     ****      LEVELS 2 THRU KMAX                                        QINITE.57
C     ****                                                                QINITE.58
      DO I=LEN1+1,LEN2                                                    QINITE.59
       S4(I,1)=.5*(F(I,NTK)+F(I,NTK-1))                                   QINITE.60
      ENDDO                                                               QINITE.61
C     ****                                                                QINITE.62
C     ****      LEVELS 1 AND KMAXP1                                       QINITE.63
C     ****                                                                QINITE.64
      DO I=1,LEN1                                                         QINITE.65
       S4(I,1)=F(I,NTK+KMAX)                                              QINITE.66
       S4(I,KMAXP1)=F(I,NTK+KMAXM1)                                       QINITE.67
      ENDDO                                                               QINITE.68
C     ****                                                                QINITE.69
C     ****      S5 =N*MBAR              (K)                               QINITE.70
C     ****                                                                QINITE.71
      DO K=1,KMAX                                                         QINITE.72
       DO I=1,LEN1                                                        QINITE.73
        S5(I,K)=C(87)*EXPS(K)                                             QINITE.74
       ENDDO                                                              QINITE.75
      ENDDO                                                               QINITE.76
      DO I=1,LEN1                                                         QINITE.77
       S5(I,KMAXP1)=C(86)*EXPS(KMAX)                                      QINITE.78
      ENDDO                                                               QINITE.79
      NMSK=NJ+NMS                                                         QINITE.80
      DO I=1,LEN3                                                         QINITE.81
       S5(I,1)=C(81)*S5(I,1)*F(I,NMSK)/(C(84)*S4(I,1))                    QINITE.82
      ENDDO                                                               QINITE.83
C     ****                                                                QINITE.84
C     ****      CALCULATE IONIZATION OF O2, O, N2 IN S6, S7, S8           QINITE.85
C     ****                                                                QINITE.86
C     ****      INITIALIZATION  S6 = S7 = S8 = 0.                         QINITE.87
C     ****                                                                QINITE.88
      DO I=1,3*LEN3                                                       QINITE.89
       S8(I,1)=0.                                                         QINITE.90
      ENDDO                                                               QINITE.91
C     ****                                                                QINITE.92
C     ****      SUMMATION OVER WAVE LENGTH                                QINITE.93
C     ****                                                                QINITE.94
      NNVO2K=NNVO2                                                        QINITE.95
      NNVOK=NNVO                                                          QINITE.96
      NNVN2K=NNVN2                                                        QINITE.97
      DO N=1,3                                                            QINITE.98
C      ****                                                               QINITE.99
C      ****      S9 = EXP(-TAU)                                           QINITE.100
C      ****                                                               QINITE.101
       DO I=1,LEN3                                                        QINITE.102
        S9(I,1)=DEXP(-(SA(1,N)*F(I,NNVO2K)+SA(2,N)*F(I,NNVOK)+            QINITE.103
     1          SA(3,N)*F(I,NNVN2K)))                                     QINITE.104
       ENDDO                                                              QINITE.105
C      ****                                                               QINITE.106
C      ****      ADD O2, O, N2 IONIZATION TO S6, S7, S8                   QINITE.107
C      ****                                                               QINITE.108
       DO I=1,LEN3                                                        QINITE.109
        S8(I,1)=S8(I,1)+AL(N)*SI(3,N)*S3(I,1)*S9(I,1)/RMASS(3)            QINITE.110
        S7(I,1)=S7(I,1)+AL(N)*SI(2,N)*S2(I,1)*S9(I,1)/RMASS(2)            QINITE.111
        S6(I,1)=S6(I,1)+AL(N)*SI(1,N)*S1(I,1)*S9(I,1)/RMASS(1)            QINITE.112
       ENDDO                                                              QINITE.113
      ENDDO                                                               QINITE.114
C     ****                                                                QINITE.115
C     ****      CALCULATE CONTRIBUTIONS TO NQO2P, NQOP, NQN2P, NQNP       QINITE.116
C     ****                                                                QINITE.117
      NQO2PK=NQO2P                                                        QINITE.118
      NQOPK=NQOP                                                          QINITE.119
      NQN2PK=NQN2P                                                        QINITE.120
      NQNPK=NQNP                                                          QINITE.121
      DO I=1,LEN3                                                         QINITE.122
       F(I,NQO2PK)=F(I,NQO2PK)+0.67*S6(I,1)*S5(I,1)                       QINITE.123
       F(I,NQOPK)=F(I,NQOPK)+(0.33*S6(I,1)+S7(I,1))*S5(I,1)               QINITE.124
       F(I,NQN2PK)=F(I,NQN2PK)+0.86*S8(I,1)*S5(I,1)                       QINITE.125
       F(I,NQNPK)=F(I,NQNPK)+0.14*S8(I,1)*S5(I,1)                         QINITE.126
      ENDDO                                                               QINITE.127
C     ****                                                                QINITE.128
C     ****      CALCULATE NO IONIZATION AND ADD TO NQNOP                  QINITE.129
C     ****                                                                QINITE.130
      NQNOPK=NQNOP                                                        QINITE.131
      NNVO2K=NNVO2                                                        QINITE.132
      NPNOK=NJ+NPNO                                                       QINITE.133
C     ****                                                                QINITE.134
C     ****      LEVEL 1                                                   QINITE.135
C     ****                                                                QINITE.136
      DO I=1,LEN1                                                         QINITE.137
       F(I,NQNOPK)=F(I,NQNOPK)+BETA9N(I,1)*F(I,NPNOK)*S5(I,1)/RMNO        QINITE.138
      ENDDO                                                               QINITE.139
C     ****                                                                QINITE.140
C     ****      LEVELS 2 THRU KMAXP1                                      QINITE.141
C     ****                                                                QINITE.142
      DO I=LEN1+1,LEN3                                                    QINITE.143
       F(I,NQNOPK)=F(I,NQNOPK)+BETA9N(I,1)*.5*(F(I,NPNOK)+                QINITE.144
     1             F(I,NPNOK-1))*S5(I,1)/RMNO                             QINITE.145
      ENDDO                                                               QINITE.146
      RETURN                                                              QINITE.147
      END                                                                 QINITE.148
C                                                                         QINITE.149
*DK QJION                                                                  QJION.1
      SUBROUTINE QJION                                                     QJION.2
C     ****                                                                 QJION.3
C     ****     CALCULATES ION CHEMISTRY CONTRIBUTION TO NEUTRAL GAS        QJION.4
C     ****     HEATING                                                     QJION.5
C     ****                                                                 QJION.6
      INCLUDE 'param.h'                                                    QJION.7
      INCLUDE 'vscrw.h'                                                    QJION.8
      INCLUDE 'const.h'                                                    QJION.9
      INCLUDE 'index.h'                                                    QJION.10
      INCLUDE 'buffe.h'                                                    QJION.11
      INCLUDE 'phycs.h'                                                    QJION.12
      INCLUDE 'rates.h'                                                    QJION.13
      COMMON/MASS/RMN4S,RMN2D,RMNO,BRN2D,CEE                               QJION.14
      DIMENSION AUREFF(ZKMXP)                                              QJION.15
      DATA AUREFF/ZKMXP*0.05/                                              QJION.16
C     ****                                                                 QJION.17
C     ****     S12 = N*MBAR =PO*EXP(-Z)*MBAR/(K*T)      (K+1/2)            QJION.18
C     ****                                                                 QJION.19
      NTK=NJ+NT-1                                                          QJION.20
      NMSK=NJ+NMS-1                                                        QJION.21
      DO K=1,KMAX                                                          QJION.22
       NTK=NTK+1                                                           QJION.23
       NMSK=NMSK+1                                                         QJION.24
       DO I=1,LEN1                                                         QJION.25
        S12(I,K)=C(81)*EXPS(K)*.5*(F(I,NMSK)+F(I,NMSK+1))/                 QJION.26
     1           (C(84)*F(I,NTK))                                          QJION.27
       ENDDO                                                               QJION.28
      ENDDO                                                                QJION.29
C     ****                                                                 QJION.30
C     ****     S11 = N*MBAR =PO*EXP(-Z)*MBAR/(K*T)      (K)                QJION.31
C     ****                                                                 QJION.32
      NTK=NJ+NT                                                            QJION.33
      NMSK=NJ+NMS                                                          QJION.34
C     ****                                                                 QJION.35
C     ****     LEVELS 1 AND KMAXP1                                         QJION.36
C     ****                                                                 QJION.37
      DO I=1,LEN1                                                          QJION.38
       S11(I,1)=C(81)*C(87)*EXPS(1)*F(I,NMSK)/(C(84)*.5*(3.*F(I,NTK)-      QJION.39
     1          F(I,NTK+1)))                                               QJION.40
       S11(I,KMAXP1)=C(81)*C(86)*EXPS(KMAX)*F(I,NMSK+KMAX)/(C(84)*.5*      QJION.41
     1               (3.*F(I,NTK+KMAXM1)-F(I,NTK+KMAXM1-1)))               QJION.42
      ENDDO                                                                QJION.43
C     ****                                                                 QJION.44
C     ****     LEVELS 2 THRU KMAX                                          QJION.45
C     ****                                                                 QJION.46
      DO K=2,KMAX                                                          QJION.47
       NTK=NTK+1                                                           QJION.48
       NMSK=NMSK+1                                                         QJION.49
       DO I=1,LEN1                                                         QJION.50
        S11(I,K)=C(81)*C(87)*EXPS(K)*F(I,NMSK)/(C(84)*.5*(F(I,NTK)+        QJION.51
     1           F(I,NTK-1)))                                              QJION.52
       ENDDO                                                               QJION.53
      ENDDO                                                                QJION.54
C     ****                                                                 QJION.55
C     ****     S1 = QT   (TOTAL IONIZATION RATE)      (K)                  QJION.56
C     ****                                                                 QJION.57
C     ****     S1 = 0.                                                     QJION.58
C     ****                                                                 QJION.59
      DO I=1,LEN3                                                          QJION.60
       S1(I,1)=0.                                                          QJION.61
      ENDDO                                                                QJION.62
C     ****                                                                 QJION.63
C     ****     SUMMATION OVER 5 ION SPECIES                                QJION.64
C     ****                                                                 QJION.65
      DO N=1,5                                                             QJION.66
       NQPK=NQO2P+(N-1)*KMAXP1                                             QJION.67
       DO I=1,LEN3                                                         QJION.68
        S1(I,1)=S1(I,1)+F(I,NQPK)                                          QJION.69
       ENDDO                                                               QJION.70
      ENDDO                                                                QJION.71
      DO I=1,LEN3                                                          QJION.72
       S1(I,1)=S1(I,1)+QOP2P(I,1)+QOP2D(I,1)                               QJION.73
      ENDDO                                                                QJION.74
C     ****                                                                 QJION.75
C     ****     S2 = QPHOTO     (PHOTO ELECTRON HEATING OF NEUTRAL GAS) (   QJION.76
C     ****                                                                 QJION.77
      DO K=1,KMAXP1                                                        QJION.78
       DO I=1,LEN1                                                         QJION.79
        S2(I,K)=S1(I,K)*AUREFF(K)*35.*C(85)*1.602D-12/S11(I,K)             QJION.80
       ENDDO                                                               QJION.81
      ENDDO                                                                QJION.82
C     ****                                                                 QJION.83
C     ****     S3 = QIC  (ION CHEMISTRY HEATING OF NEUTRAL GAS) (K=1/2)    QJION.84
C     ****                                                                 QJION.85
      NPS1K=NJ+NPS                                                         QJION.86
      NPS2K=NJ+NPS2                                                        QJION.87
      NO2PK=NJ+NO2P                                                        QJION.88
      NOPK=NJ+NOP                                                          QJION.89
      NN2PK=NN2P                                                           QJION.90
      NNPK=NNP                                                             QJION.91
      NNOPK=NNOP                                                           QJION.92
      NPN4SK=NJ+NPN4S                                                      QJION.93
      NPN2DK=NJ+NPN2D                                                      QJION.94
      NPNOK=NJ+NPNO                                                        QJION.95
      NEK=NJ+NE                                                            QJION.96
      DO I=1,LEN2                                                          QJION.97
      S3(I,1)=(C(85)*(F(I,NPS1K)/RMASS(1)*(RK1(I,1,1)*F(I,NOPK)*1.555+     QJION.98
     1        (RK6(I,1)*2.486+RK7(I,1)*6.699)*F(I,NNPK)+RK9(I,1)*          QJION.99
     2        F(I,NN2PK)*3.52)+F(I,NOPK)*(RK2(I,1)*(1.-F(I,NPS1K)-         QJION.100
     3        F(I,NPS2K))/RMASS(3)*1.0888+RK10(I,1)*F(I,NPN2DK)/           QJION.101
     4        RMN2D*1.45)+F(I,NPS2K)/RMASS(2)*(RK3(I,1)*F(I,NN2PK)*0.7+    QJION.102
     5        RK8(I,1)*F(I,NNPK)*0.98)+F(I,NO2PK)*(RK4(I,1)*F(I,NPN4SK)/   QJION.103
     6        RMN4S*4.21+RK5(I,1)*F(I,NPNOK)/RMNO*2.813))+.5*(F(I,NEK)+    QJION.104
     7        F(I,NEK+1))*(RA1(I,1)*F(I,NOPK)*0.854+RA2(I,1)*F(I,NO2PK)*   QJION.105
     8        5.2755+RA3(I,1)*F(I,NN2PK)*3.678)/S12(I,1))*1.602D-12+       QJION.106
     1        (C(85)*(((RK16(I,1)*3.02+RK17(I,1)*0.7)*(1.-F(I,NPS1K)-      QJION.107
     2        F(I,NPS2K))/RMASS(3)+RK18(I,1)*F(I,NPS2K)/RMASS(2)*5.0)*     QJION.108
     3        XIOP2P(I,1)+(RK23(I,1)*(1.-F(I,NPS1K)-F(I,NPS2K))/           QJION.109
     4        RMASS(3)*1.33+RK24(I,1)*F(I,NPS2K)/RMASS(2)*3.31+            QJION.110
     5        RK26(I,1)*4.87*F(I,NPS1K)/RMASS(1))*XIOP2D(I,1))+(0.5*       QJION.111
     6        (F(I,NEK)+F(I,NEK+1))*((RK19(I,1)*5.0+RK20(I,1)*1.69)*       QJION.112
     7        XIOP2P(I,1)+RK25(I,1)*3.31*XIOP2D(I,1))-(RK21(I,1)*5.02+     QJION.113
     8        RK22(I,1)*1.69)*XIOP2P(I,1)-RK27(I,1)*3.33*XIOP2D(I,1))/     QJION.114
     9        S12(I,1))*1.602D-12                                          QJION.115
      ENDDO                                                                QJION.116
C     ****                                                                 QJION.117
C     ****     ADD QPHOTO AND QIC TO Q    (K)                              QJION.118
C     ****                                                                 QJION.119
      NQK=NQ                                                               QJION.120
C     ****                                                                 QJION.121
C     ****     LEVELS 2 THRU KMAX                                          QJION.122
C     ****                                                                 QJION.123
      DO I=1,LEN2-LEN1                                                     QJION.124
       F(I,NQK+1)=F(I,NQK+1)+(S2(I,2)+DSQRT(S3(I,1)*S3(I,2)))              QJION.125
      ENDDO                                                                QJION.126
C     ****                                                                 QJION.127
C     ****     LEVELS 1 AND KMAXP1                                         QJION.128
C     ****                                                                 QJION.129
      DO I=1,LEN1                                                          QJION.130
      F(I,NQK)=F(I,NQK)+(S2(I,1)+DSQRT(S3(I,1)**3/S3(I,2)))                QJION.131
      F(I,NQK+KMAX)=F(I,NQK+KMAX)+(S2(I,KMAXP1)+DSQRT(S3(I,KMAX)**3/       QJION.132
     1               S3(I,KMAXM1)))                                        QJION.133
      ENDDO                                                                QJION.134
      RETURN                                                               QJION.135
      END                                                                  QJION.136
C                                                                          QJION.137
*DK QJNNO                                                                  QJNNO.1
      SUBROUTINE QJNNO                                                     QJNNO.2
C     ****                                                                 QJNNO.3
C     ****      CALCULATES ADDITIONS TO NEUTRAL GAS HEATING                QJNNO.4
C     ****      DUE TO N, NO CHEMISTRY                                     QJNNO.5
C     ****                                                                 QJNNO.6
C     ****      NOTE:  CMPN2D MUST BE CALLED BEFORE THLIS SUBROUTINE       QJNNO.7
C     ****      IS CALLED                                                  QJNNO.8
C     ****                                                                 QJNNO.9
      INCLUDE 'param.h'                                                    QJNNO.10
      INCLUDE 'vscrw.h'                                                    QJNNO.11
      INCLUDE 'const.h'                                                    QJNNO.12
      INCLUDE 'index.h'                                                    QJNNO.13
      INCLUDE 'buffe.h'                                                    QJNNO.14
      INCLUDE 'rates.h'                                                    QJNNO.15
      COMMON/MASS/ RMN4S,RMN2D,RMNO,BRN2D,CEE                              QJNNO.16
      NPNOK=NJ+NPNO                                                        QJNNO.17
      NPN4SK=NJ+NPN4S                                                      QJNNO.18
      NPN2DK=NPN2D+NJNP                                                    QJNNO.19
      NTK=NJ+NT                                                            QJNNO.20
      NPS1K=NJ+NPS                                                         QJNNO.21
      NPS2K=NPS1K+KMAXP1                                                   QJNNO.22
      NNO2K=NNO2                                                           QJNNO.23
      NEK=NJ+NE                                                            QJNNO.24
      NQK=NQ                                                               QJNNO.25
C     ****                                                                 QJNNO.27
C     ****      S1 = NMBAR       (K+1/2)                                   QJNNO.28
C     ****                                                                 QJNNO.29
      DO K=1,KMAX                                                          QJNNO.30
       DO I=1,LEN1                                                         QJNNO.31
        S1(I,K)=EXPS(K)                                                    QJNNO.32
       ENDDO                                                               QJNNO.33
      ENDDO                                                                QJNNO.34
      DO I=1,LEN2                                                          QJNNO.35
       S1(I,1)=C(81)*S1(I,1)/(C(84)*F(I,NTK)*(F(I,NPS1K)/RMASS(1)+         QJNNO.36
     1         F(I,NPS2K)/RMASS(2)+(1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3)))   QJNNO.37
      ENDDO                                                                QJNNO.38
      DO I=1,LEN2                                                          QJNNO.39
C      ****                                                                QJNNO.40
C      ****      S2 = DELTA(Q)       (K+1/2)                               QJNNO.41
C      ****                                                                QJNNO.42
       S2(I,1)=1.602D-12*C(85)*S1(I,1)*(F(I,NPN4SK)/RMN4S*(BETA1(I,1)*     QJNNO.43
     1         F(I,NPS1K)/RMASS(1)*1.4+BETA3(I,1)*F(I,NPNOK)/RMNO*2.68)+   QJNNO.44
     2         F(I,NPN2DK)/RMN2D*(BETA2(I,1)*F(I,NPS1K)/RMASS(1)*1.84+     QJNNO.45
     3         BETA4(I,1)*F(I,NPS2K)/RMASS(2)*2.38+BETA5(I,1)*.5*          QJNNO.46
     4         (F(I,NEK)+F(I,NEK+1))*2.38/S1(I,1)+BETA6(I,1)*              QJNNO.47
     5         F(I,NPNOK)/RMNO*5.63))                                      QJNNO.48
      ENDDO                                                                QJNNO.54
C     ****                                                                 QJNNO.55
C     ****      ADD DELTA(Q) TO Q         (K)                              QJNNO.56
C     ****                                                                 QJNNO.58
C     ****      LEVELS 2 THU KMAX                                          QJNNO.59
C     ****                                                                 QJNNO.60
      N0=0
      DO I=LEN1+1,LEN2                                                     QJNNO.61
       S7(I,1)=S2(I,N0)*S2(I,1)                                             QJNNO.62
       IF(S7(I,1).LE.0.)S7(I,1)=1.D-20                                     QJNNO.63
       F(I,NQK)=F(I,NQK)+DSQRT(S7(I,1))                                    QJNNO.64
      ENDDO                                                                QJNNO.65
C     ****                                                                 QJNNO.66
C     ****      LEVELS 1 AND KMAXP1                                        QJNNO.67
C     ****                                                                 QJNNO.68
      DO I=1,LEN1                                                          QJNNO.69
      F(I,NQK)=F(I,NQK)+1.5*S2(I,1)-0.5*S2(I,2)                            QJNNO.70
      F(I,NQK+KMAX)=F(I,NQK+KMAX)+1.5*S2(I,KMAX)-0.5*S2(I,KMAXM1)          QJNNO.71
      ENDDO                                                                QJNNO.72
      RETURN                                                               QJNNO.73
      END                                                                  QJNNO.74
C                                                                          QJNNO.75
*DK QRJCNT
      BLOCK DATA QRJCNT
      INCLUDE 'param.h'                                                      QRJ.8
      COMMON/DATES/FEUV(59),FSRC(15),SIGEUV(3,59),SIGMAS(6,59),              QRJ.15
     &            SIGSRC(15),RLMSRC(15),EUVEFF(ZKMXP),RLMEUV(59)             QRJ.16
      DATA RLMEUV/0.17250D-04, 0.16750D-04, 0.16250D-04, 0.15750D-04,        QRJ.20
     +           0.15250D-04, 0.14750D-04, 0.14250D-04, 0.13750D-04,         QRJ.21
     +           0.13250D-04, 0.12750D-04, 0.12250D-04, 0.12157D-04,         QRJ.22
     +           0.11750D-04, 0.11250D-04, 0.10750D-04, 0.10250D-04,         QRJ.23
     +           0.10319D-04, 0.10257D-04, 0.97500D-05, 0.97702D-05,         QRJ.24
     +           0.92500D-05, 0.87500D-05, 0.82500D-05, 0.77500D-05,         QRJ.25
     +           0.78936D-05, 0.77041D-05, 0.76515D-05, 0.72500D-05,         QRJ.26
     +           0.70331D-05, 0.67500D-05, 0.62500D-05, 0.62973D-05,         QRJ.27
     +           0.60976D-05, 0.57500D-05, 0.58433D-05, 0.55437D-05,         QRJ.28
     +           0.52500D-05, 0.47500D-05, 0.46522D-05, 0.42500D-05,         QRJ.29
     +           0.37500D-05, 0.36807D-05, 0.32500D-05, 0.30378D-05,         QRJ.30
     +           0.30331D-05, 0.27500D-05, 0.28415D-05, 0.25630D-05,         QRJ.31
     +           0.22500D-05, 0.17500D-05, 0.12500D-05, 0.75000D-06,         QRJ.32
     +           0.41000D-06, 0.27500D-06, 0.19500D-06, 0.12000D-06,         QRJ.33
     +           0.60000D-07, 0.30000D-07, 0.15000D-07/                      QRJ.34
      DATA(SIGEUV(1,N),N=1,59)/                                              QRJ.35
     +             0.50, 1.50, 3.40, 6.00,10.00,13.00,                       QRJ.36
     +            15.00,12.00, 2.20, 0.30, 3.00, 0.01,                       QRJ.37
     +             0.30, 0.10, 1.00, 1.10, 1.00, 1.60,                       QRJ.38
     +            16.53, 4.00,15.54, 9.85,20.87,27.09,                       QRJ.39
     +            26.66,25.18,21.96,29.05,25.00,26.27,                       QRJ.40
     +            26.02,25.80,26.10,25.04,22.00,25.59,                       QRJ.41
     +            24.06,21.59,20.40,19.39,18.17,18.40,                       QRJ.42
     +            17.19,16.80,16.80,15.10,15.70,13.20,                       QRJ.43
     +            10.60, 7.10, 4.00, 1.18, 0.32, 0.10,                       QRJ.44
     +             1.02, 0.14, .024, .004, .0004/                            QRJ.45
      DATA(SIGEUV(2,N),N=1,59)/                                              QRJ.46
     +              18 * 0.00,                                               QRJ.47
     +             0.00, 0.00, 2.12, 4.18, 4.38, 4.23,                       QRJ.48
     +             4.28, 4.18, 4.18, 8.00,11.35,10.04,                       QRJ.49
     +            12.21,12.22,12.23,11.90,12.17,12.13,                       QRJ.50
     +            11.91,11.64,11.25,11.21, 9.64, 9.95,                       QRJ.51
     +             8.67, 7.70, 7.68, 6.61, 7.13, 6.05,                       QRJ.52
     +             5.30, 2.90, 1.60, 0.59, 0.16, 0.05,                       QRJ.53
     +             0.51, 0.07, .012, .002, .0002/                            QRJ.54
      DATA(SIGEUV(3,N),N=1,59)/                                              QRJ.55
     +              18 * 0.00,                                               QRJ.56
     +            36.16, 0.70,16.99,46.63,15.05,30.71,                       QRJ.57
     +            19.26,26.88,35.46,30.94,26.30,29.75,                       QRJ.58
     +            23.22,23.20,23.10,22.38,23.20,24.69,                       QRJ.59
     +            24.53,21.85,21.80,21.07,17.51,18.00,                       QRJ.60
     +            13.00,11.60,11.60,10.30,10.60, 9.70,                       QRJ.61
     +             8.00, 4.40, 1.90, 0.60, 0.24, 1.16,                       QRJ.62
     +             0.48, 0.09, .015, .003, .0003/                            QRJ.63
      DATA(SIGMAS(1,N),N=1,59)/                                              QRJ.64
     +             0.00, 0.00, 0.00, 0.00, 0.00, 0.00,                       QRJ.65
     +             0.00, 0.00, 0.00, 0.00, 0.00, 0.00,                       QRJ.66
     +             0.00, 0.00, 0.00, 0.27, 0.00, 1.00,                       QRJ.67
     +            12.22, 2.50, 9.34, 4.69, 6.12, 9.39,                       QRJ.68
     +            11.05, 9.69, 8.59,23.81,23.00,22.05,                       QRJ.69
     +            25.94,25.80,26.10,25.04,22.00,25.59,                       QRJ.70
     +            24.06,21.59,20.40,19.39,18.17,18.40,                       QRJ.71
     +            17.19,16.80,16.80,15.10,15.70,13.20,                       QRJ.72
     +            10.60, 7.10, 4.00, 1.18, 0.32, 0.10,                       QRJ.73
     +             1.02, 0.14, .024, .004, .0004/                            QRJ.74
      DATA(SIGMAS(2,N),N=1,59)/                                              QRJ.75
     +              20 * 0.00, 2.12, 4.18, 4.38, 4.23,                       QRJ.77
     +             4.28, 4.18, 4.18, 4.20, 4.91, 4.01,                       QRJ.78
     +             3.78, 3.79, 3.67, 3.45, 3.53, 3.52,                       QRJ.79
     +             3.45, 3.26, 3.15, 3.03, 2.51, 2.59,                       QRJ.80
     +             2.25, 1.93, 1.92, 1.65, 1.78, 1.51,                       QRJ.81
     +             1.38, 0.78, 0.46, 0.18, 0.05, 0.015,                      QRJ.82
     +             0.015, 0.02, .004, .0006, .00006/                         QRJ.83
      DATA(SIGMAS(3,N),N=1,59)/                                              QRJ.84
     +              18 * 0.00,                                               QRJ.85
     +             0.00, 0.00, 0.00, 0.00, 0.00,16.75,                       QRJ.86
     +            10.18,18.39,23.77,23.20,23.00,25.06,                       QRJ.87
     +            23.22,23.20,23.10,22.38,23.20,24.69,                       QRJ.88
     +            24.53,21.85,21.80,21.07,17.51,18.00,                       QRJ.89
     +            13.00,11.60,11.60,10.30,10.60, 9.70,                       QRJ.90
     +             8.00, 4.40, 1.90, 0.60, 0.24, 1.16,                       QRJ.91
     +             0.48, 0.09, .015, .003, .0003/                            QRJ.92
      DATA(SIGMAS(4,N),N=1,59)/                                              QRJ.93
     +              22 * 0.00,                                               QRJ.94
     +             1.00, 1.00, 1.00, 1.00, 1.10, 1.10,                       QRJ.95
     +             1.10, 1.20, 1.20, 1.20, 1.20, 1.20,                       QRJ.96
     +             1.10, 1.20, 1.15, 1.10, 1.00, 1.00,                       QRJ.97
     +             1.00, 0.70, 0.80, 0.65, 0.60, 0.60,                       QRJ.98
     +             0.50, 0.50, 0.40, 0.35, 0.25, 0.20,                       QRJ.99
     +             0.10, 0.10, 0.10, 0.05, 0.01,                             QRJ.100
     +             2*0.0/                                                    QRJ.101
      DATA(SIGMAS(5,N),N=1,59)/                                              QRJ.102
     +              27 * 0.00, 3.80, 6.44, 5.52, 5.49,                       QRJ.103
     +             5.50, 5.50, 5.36, 5.48, 5.46, 5.36,                       QRJ.104
     +             5.24, 5.06, 4.71, 3.86, 3.98, 3.47,                       QRJ.105
     +             2.85, 2.84, 2.38, 2.64, 2.12, 1.86,                       QRJ.106
     +             0.99, 0.51, 0.19, 0.05, 0.015, 0.015,                     QRJ.107
     +             0.02, 0.004, 0.0006, 0.00006/                             QRJ.108
      DATA(SIGMAS(6,N),N=1,59)/                                              QRJ.109
     +              29 * 0.00, 0.50, 2.93, 2.93, 3.06,                       QRJ.110
     +             3.09, 3.16, 3.15, 3.10, 3.14, 3.04,                       QRJ.111
     +             3.48, 3.28, 3.38, 2.95, 2.93, 2.92,                       QRJ.112
     +             2.58, 2.71, 2.42, 2.07, 1.13, 0.62,                       QRJ.113
     +             0.22, 0.06, 0.02, 0.02, 0.03, 0.004,                      QRJ.114
     +             0.0007, 0.00007/                                          QRJ.115
      DATA EUVEFF/29*0.05/
      END
*DK QRJ                                                                      QRJ.1
      SUBROUTINE QRJ                                                         QRJ.2
C     ****                                                                   QRJ.3
C     ****      CALCULATE HEATING AND DISSOCIATION RATES                     QRJ.4
C     ****      CHAPMAN INTEGRAL FOR EACH SPECIES AT EACH GRID               QRJ.5
C     ****      POINT IN NNO2, NNO, NNN2 (CALCULATED BY SUB CHAPMN)          QRJ.6
C     ****                                                                   QRJ.7
      INCLUDE 'param.h'                                                      QRJ.8
      INCLUDE 'vscrw.h'                                                      QRJ.9
      INCLUDE 'const.h'                                                      QRJ.10
      INCLUDE 'index.h'                                                      QRJ.11
      INCLUDE 'buffe.h'                                                      QRJ.12
      INCLUDE 'phycs.h'                                                      QRJ.13
      INCLUDE 'rates.h'                                                      QRJ.14
      INCLUDE 'cpbnd.h'                                                      QRJ.14
      COMMON/DATES/FEUV(59),FSRC(15),SIGEUV(3,59),SIGMAS(6,59),              QRJ.15
     &            SIGSRC(15),RLMSRC(15),EUVEFF(ZKMXP),RLMEUV(59)             QRJ.16
      COMMON/MASS/ RMN4S,RMN2D,RMNO,BRN2D,CEE                                QRJ.17
      DIMENSION QUENCH(4),SFLUX(59),BRN2(59),BRO2(59)                        QRJ.19
      DATA(BRN2(N),N=1,59)/                                                  QRJ.116
     +              36 * 0.00,                                               QRJ.117
     +             0.01, 0.04, 0.04, 0.03, 0.05, 0.05,                       QRJ.118
     +             0.15, 0.20, 0.20, 0.25, 0.32, 0.34,                       QRJ.119
     +             11 * 0.36/                                                QRJ.120
      DATA(BRO2(N),N=1,59)/                                                  QRJ.121
     +              30 * 0.00,                                               QRJ.122
     +             .025, .036, .045, .120, .155, .189,                       QRJ.123
     +             .230, 0.20, 0.20, 0.20, 0.23, 0.25,                       QRJ.124
     +             0.29, 16 * 0.33/                                          QRJ.125
      DATA DO2/8.203D-12/,AD/5.435D-9/,BD/1.232D-6/,                         QRJ.126
     1     ABAND/0.143/,BBAND/9.64D8/,CBAND/9.03D-19/                        QRJ.127
      DATA DO22/1.1407D-11/                                                  QRJ.128
      DATA QUENCH/7.D-11,5.D-11,3.1401D-12,9.1D-3/                           QRJ.129
      DATA ISTART/0/                                                         QRJ.130
      DATA E3/0.33/                                                          QRJ.131
      F107  = C(61)                                                          QRJ.132
      F107A = C(62)                                                          QRJ.133
      ISCALE = 0                                                             QRJ.134
C     ****                                                                   QRJ.135
C     ****       THE FLAG ISCALE CHOOSES THE FLUX MODELING METHOD            QRJ.136
C     ****       FROM THE SUBROUTINE SSFLUX. ISCALE=0 DOES SOLOMON'S,        QRJ.137
C     ****       ISCALE=1 DOES A LIN. INTERP.,AND ISCALE=2 DOES TOBISKA'     QRJ.138
C     ****                                                                   QRJ.139
      IF(J.EQ.1) THEN                                                        QRJ.140
       CALL SSFLUX(ISCALE,F107,F107A,FLYA,SFLUX)                             QRJ.141
C      ****                                                                  QRJ.142
C      ****     TRANSFER VALUES OF SFLUX TO APPROPRIATE SLOTS                QRJ.143
C      ****                                                                  QRJ.144
       DO N=16,59                                                            QRJ.145
        FEUV(N)=SFLUX(N)                                                     QRJ.146
       ENDDO                                                                 QRJ.147
       DO N = 1,15                                                           QRJ.148
        FSRC(N)   = SFLUX(N)                                                 QRJ.149
       ENDDO                                                                 QRJ.150
      ENDIF                                                                  QRJ.151
C     ****                                                                   QRJ.152
C     ****      INITIALIZATION UPON FIRST ENTRY                              QRJ.153
C     ****                                                                   QRJ.154
      IF(ISTART.EQ.0) THEN                                                   QRJ.155
       ISTART=1                                                              QRJ.156
       DO M=1,3                                                              QRJ.157
        DO N=1,59                                                            QRJ.158
         SIGEUV(M,N)=SIGEUV(M,N)*1.D-18                                      QRJ.159
         SIGMAS(M,N)=SIGMAS(M,N)*1.D-18                                      QRJ.160
        ENDDO                                                                QRJ.161
       ENDDO                                                                 QRJ.162
       DO N=1,59                                                             QRJ.163
        SIGMAS(4,N)=SIGMAS(4,N)*1.D-17                                       QRJ.164
        SIGMAS(5,N)=SIGMAS(5,N)*1.D-18                                       QRJ.165
        SIGMAS(6,N)=SIGMAS(6,N)*1.D-18                                       QRJ.166
       ENDDO                                                                 QRJ.167
       DO N=1,15                                                             QRJ.168
        RLMSRC(N)=RLMEUV(N)                                                  QRJ.169
        SIGSRC(N)=SIGEUV(1,N)                                                QRJ.170
       ENDDO                                                                 QRJ.171
      ENDIF                                                                  QRJ.172
C     ****                                                                   QRJ.173
C     ****                                                                   QRJ.174
C     ****     COMPUTE S14 = RSQ, S15 = RSP                                  QRJ.175
C     ****                                                                   QRJ.176
C     ****                                                                   QRJ.177
C     ****     S1 = TAU(R),  S2 = TAU(Q)                                     QRJ.178
C     ****                                                                   QRJ.179
      NNO2K=NNO2                                                             QRJ.180
      NNOK=NNO                                                               QRJ.181
      NNN2K=NNN2                                                             QRJ.182
      DO I=1,LEN3                                                            QRJ.183
       S1(I,1)=SIGEUV(1,49)*F(I,NNO2K)+SIGEUV(2,49)*F(I,NNOK)+               QRJ.184
     1         SIGEUV(3,49)*F(I,NNN2K)                                       QRJ.185
       S2(I,1)=SIGEUV(1,20)*F(I,NNO2K)+SIGEUV(2,20)*F(I,NNOK)+               QRJ.186
     1         SIGEUV(3,20)*F(I,NNN2K)                                       QRJ.187
C      ****                                                                  QRJ.188
C      ****     S3 = TAU(1), S4 = TAU(2), S5 = TAU(3)                        QRJ.189
C      ****                                                                  QRJ.190
       S3(I,1)=1.3*S1(I,1)                                                   QRJ.191
       S4(I,1)=2.0*S1(I,1)                                                   QRJ.192
       S5(I,1)=2.5*S1(I,1)                                                   QRJ.193
C      ****                                                                  QRJ.194
C      ****     IF(TAU.GT.9.0) TAU = 9.0                                     QRJ.195
C      ****                                                                  QRJ.196
       IF((9.0-S1(I,1)).LT.0.)S1(I,1)=9.0                                    QRJ.197
       IF((9.0-S2(I,1)).LT.0.)S2(I,1)=9.0                                    QRJ.198
       IF((9.0-S3(I,1)).LT.0.)S3(I,1)=9.0                                    QRJ.199
       IF((9.0-S4(I,1)).LT.0.)S4(I,1)=9.0                                    QRJ.200
       IF((9.0-S5(I,1)).LT.0.)S5(I,1)=9.0                                    QRJ.201
C      ****                                                                  QRJ.202
C      ****     TAU(N) = EXP(-TAU(N)) FOR N = 1,3,1                          QRJ.203
C      ****                                                                  QRJ.204
       S3(I,1)=DEXP(-S3(I,1))                                                QRJ.205
       S4(I,1)=DEXP(-S4(I,1))                                                QRJ.206
       S5(I,1)=DEXP(-S5(I,1))                                                QRJ.207
C      ****                                                                  QRJ.208
C      ****     S6 = EXP(-TAU(R)), S7 = EXP(-TAU(Q))                         QRJ.209
C      ****                                                                  QRJ.210
       S6(I,1)=DEXP(-S1(I,1))                                                QRJ.211
       S7(I,1)=DEXP(-S2(I,1))                                                QRJ.212
C      ****                                                                  QRJ.213
C      ****     S14 = RSP, S15 = RSQ                                         QRJ.214
C      ****                                                                  QRJ.215
       S14(I,1)=S6(I,1)+2.*(S3(I,1)+S4(I,1)+S5(I,1))                         QRJ.216
       S15(I,1)=1.5*S6(I,1)/(S14(I,1)+S2(I,1)/S1(I,1)*S7(I,1))               QRJ.217
       S14(I,1)=2.4*S6(I,1)/S14(I,1)                                         QRJ.218
      ENDDO                                                                  QRJ.219
C     ****                                                                   QRJ.220
C     ****                                                                   QRJ.221
C     ****     S1 = PSI(O2), S2 = PSI(O), S3 = PSI(N2), S4 = PSI(N4S)        QRJ.222
C     ****                                                                   QRJ.223
C     ****                                                                   QRJ.224
      NPS1K=NJ+NPS                                                           QRJ.225
      NPS2K=NJ+NPS2                                                          QRJ.226
      NPN4SK=NJ+NPN4S                                                        QRJ.227
C     ****                                                                   QRJ.228
C     ****      LEVELS 2 THRU KMAXP1                                         QRJ.229
C     ****                                                                   QRJ.230
      DO I=1,LEN2                                                            QRJ.231
       S1(I,2)=.5*(F(I,NPS1K)+F(I,NPS1K+1))                                  QRJ.232
       S2(I,2)=.5*(F(I,NPS2K)+F(I,NPS2K+1))                                  QRJ.233
       S4(I,2)=0.                                                            QRJ.234
      ENDDO                                                                  QRJ.235
C     ****                                                                   QRJ.236
C     ****      LEVEL 1                                                      QRJ.237
C     ****                                                                   QRJ.238
      DO I=1,LEN1                                                            QRJ.239
       S1(I,1)=.5*((B(I,1,1)+1.)*F(I,NPS1K)+B(I,1,2)*F(I,NPS2K)+FB(I,1))     QRJ.240
       S2(I,1)=.5*(B(I,2,1)*F(I,NPS1K)+(B(I,2,2)+1.)*F(I,NPS2K)+FB(I,2))     QRJ.241
       S4(I,1) = 0.                                                          QRJ.242
      ENDDO                                                                  QRJ.243
C     ****                                                                   QRJ.244
C     ****      NOW CALCULATE S3 = PSI(N2)                                   QRJ.245
C     ****                                                                   QRJ.246
      DO I=1,LEN3                                                            QRJ.247
       S3(I,1)=1.-S1(I,1)-S2(I,1)                                            QRJ.248
      ENDDO                                                                  QRJ.249
C     ****                                                                   QRJ.250
C     ****     CALCULATE IONIZATION CONTRIBUTIONS IN S8 - S13                QRJ.251
C     ****                                                                   QRJ.252
C     ****       S8 = O2 IONIZATION                                          QRJ.253
C     ****       S9 = O IONIZATION                                           QRJ.254
C     ****       S10 = N2 IONIZATION                                         QRJ.255
C     ****       S11 = N4S IONIZATION                                        QRJ.256
C     ****       S12 = O2 IONIZATION * BRO2                                  QRJ.257
C     ****       S13 = N2 IONIZATION * BRN2                                  QRJ.258
C     ****                                                                   QRJ.259
C     ****     CONTRIBUTIONS TO Q, J AND QTEF FROM EUV                       QRJ.260
C     ****                                                                   QRJ.261
C     ****     INITIALIZE Q, RJ AND QTEF                                     QRJ.262
C     ****                                                                   QRJ.263
      NQK=NQ                                                                 QRJ.264
      NRJK=NRJ                                                               QRJ.265
      NQTEFK=NQTEF                                                           QRJ.266
      DO I=1,LEN3                                                            QRJ.267
       F(I,NQK)=0.                                                           QRJ.268
       F(I,NRJK)=0.                                                          QRJ.269
       F(I,NQTEFK)=0.                                                        QRJ.270
       QOP2P(I,1)=0.                                                         QRJ.271
       QOP2D(I,1)=0.                                                         QRJ.272
      ENDDO                                                                  QRJ.273
C     ****                                                                   QRJ.274
C     ****      INITIALIZE S8 - S13                                          QRJ.275
C     ****                                                                   QRJ.276
      DO I=1,6*LEN3                                                          QRJ.277
       S13(I,1)=0.                                                           QRJ.278
      ENDDO                                                                  QRJ.279
C     ****                                                                   QRJ.280
C     ****      SUMMATION OVER WAVE LENGTH                                   QRJ.281
C     ****                                                                   QRJ.282
      DO N=16,59                                                             QRJ.283
C      ****                                                                  QRJ.284
C      ****      S5=SUM(O2,O,N2)(SIGMA*CHAPMAN)                              QRJ.285
C      ****      S6=SUM(O2,O,N2)(SIGMA*PSI/RMASS)                            QRJ.286
C      ****      S7=SUM(O2,O,N2,N4S)(SIGMAS)                                 QRJ.287
       DO I=1,LEN3                                                           QRJ.288
        S5(I,1)=SIGEUV(1,N)*F(I,NNO2K)+SIGEUV(2,N)*F(I,NNOK)+                QRJ.289
     1          SIGEUV(3,N)*F(I,NNN2K)                                       QRJ.290
        S6(I,1)=SIGEUV(1,N)*S1(I,1)/RMASS(1)+SIGEUV(2,N)*S2(I,1)/            QRJ.291
     1          RMASS(2)+SIGEUV(3,N)*S3(I,1)/RMASS(3)                        QRJ.292
        S7(I,1)=SIGMAS(1,N)+SIGMAS(2,N)+SIGMAS(3,N)                          QRJ.293
       ENDDO                                                                 QRJ.294
       DO I=1,LEN3                                                           QRJ.295
C       ****                                                                 QRJ.296
C       ****     ADD CONTRIBUTIONS FROM N4S TO S7                            QRJ.297
C       ****                                                                 QRJ.298
        S7(I,1)=S7(I,1)+SIGMAS(4,N)                                          QRJ.299
C       ****                                                                 QRJ.301
C       ****     S5 = F(LAMDA)*EXP(-TAU)                                     QRJ.302
C       ****                                                                 QRJ.303
        S5(I,1)=FEUV(N)*DEXP(-S5(I,1))                                       QRJ.304
C       ****                                                                 QRJ.305
C       ****     ADD CONTRIBUTIONS TO Q AND RJE                              QRJ.306
C       ****                                                                 QRJ.307
        F(I,NQK)=F(I,NQK)+C(60)/RLMEUV(N)*S5(I,1)*S6(I,1)                    QRJ.308
        F(I,NRJK)=F(I,NRJK)+S5(I,1)*S7(I,1)                                  QRJ.309
        QOP2P(I,1)=QOP2P(I,1)+S5(I,1)*SIGMAS(6,N)*S2(I,1)/RMASS(2)           QRJ.310
        QOP2D(I,1)=QOP2D(I,1)+S5(I,1)*SIGMAS(5,N)*S2(I,1)/RMASS(2)           QRJ.311
       ENDDO                                                                 QRJ.312
C      ****                                                                  QRJ.313
C      ****      ADD IONIZATION FOR O2, O, N2 TO S8, S9, S10                 QRJ.314
C      ****                                                                  QRJ.315
       DO I=1,LEN3                                                           QRJ.316
        S10(I,1)=S10(I,1)+SIGMAS(3,N)*S5(I,1)*S3(I,1)/RMASS(3)               QRJ.317
        S9(I,1)=S9(I,1)+SIGMAS(2,N)*S5(I,1)*S2(I,1)/RMASS(2)                 QRJ.318
        S8(I,1)=S8(I,1)+SIGMAS(1,N)*S5(I,1)*S1(I,1)/RMASS(1)                 QRJ.319
       ENDDO                                                                 QRJ.320
       DO I=1,LEN3                                                           QRJ.321
C       ****                                                                 QRJ.322
C       ****     ADD EFFECTIVE N2 IONIZATION TO QTEF                         QRJ.323
C       ****                                                                 QRJ.324
        F(I,NQTEFK)=F(I,NQTEFK)+(SIGEUV(3,N)-SIGMAS(3,N))*S5(I,1)*           QRJ.325
     1              S3(I,1)/RMASS(3)                                         QRJ.326
C       ****                                                                 QRJ.327
C       ****     ADD N4S IONIZATION TO S11                                   QRJ.328
C       ****                                                                 QRJ.329
        S11(I,1)=S11(I,1)+SIGMAS(4,N)*S5(I,1)*S4(I,1)/RMN4S                  QRJ.330
C       ****                                                                 QRJ.331
C       ****     ADD IONIZATION CONTRIBUTIONS TO S12 AND S13                 QRJ.332
C       ****                                                                 QRJ.333
        S12(I,1)=S12(I,1)+SIGMAS(1,N)*S5(I,1)*S1(I,1)/RMASS(1)*BRO2(N)       QRJ.334
        S13(I,1)=S13(I,1)+SIGMAS(3,N)*S5(I,1)*S3(I,1)/RMASS(3)*BRN2(N)       QRJ.335
       ENDDO                                                                 QRJ.336
      ENDDO                                                                  QRJ.337
C     ****                                                                   QRJ.338
C     ****      MULTIPLY Q BY EFICIENCY FACTOR                               QRJ.339
C     ****                                                                   QRJ.340
      NQK=NQK-1                                                              QRJ.341
      DO K=1,KMAXP1                                                          QRJ.342
       NQK=NQK+1                                                             QRJ.343
       DO I=1,LEN1                                                           QRJ.344
        F(I,NQK)=F(I,NQK)*EUVEFF(K)*C(85)                                    QRJ.345
       ENDDO                                                                 QRJ.346
      ENDDO                                                                  QRJ.347
C     ****                                                                   QRJ.348
C     ****     CALCULATE N*MBAR IN S5                                        QRJ.349
C     ****                                                                   QRJ.350
C     ****       S6 = T(TOTAL,K)                                             QRJ.351
C     ****                                                                   QRJ.352
C     ****       LEVEL 1                                                     QRJ.353
C     ****                                                                   QRJ.354
      NTK=NJ+NT+KMAX                                                         QRJ.355
      DO I=1,LEN1                                                            QRJ.356
       S6(I,1)=F(I,NTK)                                                      QRJ.357
      ENDDO                                                                  QRJ.358
C     ****                                                                   QRJ.359
C     ****      LEVELS 2 THRU KMAX                                           QRJ.360
C     ****                                                                   QRJ.361
      NTK=NJ+NT-1                                                            QRJ.362
      DO K=2,KMAX                                                            QRJ.363
       NTK=NTK+1                                                             QRJ.364
       DO I=1,LEN1                                                           QRJ.365
        S6(I,K)=.5*(F(I,NTK)+F(I,NTK+1))                                     QRJ.366
       ENDDO                                                                 QRJ.367
      ENDDO                                                                  QRJ.368
C     ****                                                                   QRJ.369
C     ****      LEVEL KMAXP1                                                 QRJ.370
C     ****                                                                   QRJ.371
      NTK=NJ+NT+KMAX-1                                                       QRJ.372
      DO I=1,LEN1                                                            QRJ.373
       S6(I,KMAXP1)=F(I,NTK)                                                 QRJ.374
      ENDDO                                                                  QRJ.375
C     ****                                                                   QRJ.376
C     ****      S7 = EXPS              (K)                                   QRJ.377
C     ****                                                                   QRJ.378
      DO K=1,KMAX                                                            QRJ.379
       DO I=1,LEN1                                                           QRJ.380
        S7(I,K)=C(87)*EXPS(K)                                                QRJ.381
       ENDDO                                                                 QRJ.382
      ENDDO                                                                  QRJ.383
      DO I=1,LEN1                                                            QRJ.384
       S7(I,KMAXP1)=C(86)*EXPS(KMAX)                                         QRJ.385
      ENDDO                                                                  QRJ.386
C     ****                                                                   QRJ.387
C     ****      S5 = N*MBAR            (K)                                   QRJ.388
C     ****                                                                   QRJ.389
      NMSK=NJ+NMS                                                            QRJ.390
      DO I=1,LEN3                                                            QRJ.391
       S5(I,1)=C(81)*S7(I,1)*F(I,NMSK)/(C(84)*S6(I,1))                       QRJ.392
      ENDDO                                                                  QRJ.393
C     ****                                                                   QRJ.394
C     ****      CALCULATE CONTRIBUTIONS TO NQO2P, NQOP, NQN2P, NQNP          QRJ.395
C     ****        AND NQTEF                                                  QRJ.396
C     ****                                                                   QRJ.397
      NQO2PK=NQO2P                                                           QRJ.398
      NQOPK=NQOP                                                             QRJ.399
      NQN2PK=NQN2P                                                           QRJ.400
      NQNPK=NQNP                                                             QRJ.401
      NQTEFK=NQTEF                                                           QRJ.402
      DO I=1,LEN3                                                            QRJ.403
       F(I,NQO2PK)=F(I,NQO2PK)+(S8(I,1)*(1.+S15(I,1))-S12(I,1))*S5(I,1)      QRJ.404
       S4(I,1)=QOP2P(I,1)+QOP2D(I,1)+S9(I,1)+S12(I,1)                        QRJ.405
       F(I,NQOPK)=F(I,NQOPK)+(S9(I,1)+S12(I,1)+S4(I,1)*S14(I,1)*0.56)*       QRJ.406
     1            S5(I,1)                                                    QRJ.407
       QOP2P(I,1)=(QOP2P(I,1)+S4(I,1)*S14(I,1)*0.22)*S5(I,1)                 QRJ.408
       QOP2D(I,1)=(QOP2D(I,1)+S4(I,1)*S14(I,1)*0.24)*S5(I,1)                 QRJ.409
       F(I,NQN2PK)=F(I,NQN2PK)+(S10(I,1)*(1+S14(I,1))-S13(I,1))*S5(I,1)      QRJ.411
       F(I,NQNPK)=F(I,NQNPK)+(S11(I,1)+S13(I,1))*S5(I,1)                     QRJ.412
       F(I,NQTEFK)=F(I,NQTEFK)*S5(I,1)                                       QRJ.413
c        if(j.eq.28)write(6,*)F(I,NQO2PK),F(I,NQOPK),i,k
      ENDDO                                                                  QRJ.414
c        if(j.eq.28)pause
C     ****                                                                   QRJ.415
C     ****      CALCULATE NO IONIZATION AND ADD TO NQNOP                     QRJ.416
C     ****                                                                   QRJ.417
      NQNOPK=NQNOP                                                           QRJ.418
      NNO2K=NNO2                                                             QRJ.419
      NPNOK=NJ+NPNO                                                          QRJ.420
C     ****                                                                   QRJ.421
C     ****      LEVEL 1                                                      QRJ.422
C     ****                                                                   QRJ.423
      DO I=1,LEN1                                                            QRJ.424
       F(I,NQNOPK)=F(I,NQNOPK)+BETA9(I,1)*F(I,NPNOK)*S5(I,1)/RMNO            QRJ.425
      ENDDO                                                                  QRJ.426
C     ****                                                                   QRJ.427
C     ****      LEVELS 2 THRU KMAXP1                                         QRJ.428
C     ****                                                                   QRJ.429
      DO I=LEN1+1,LEN3                                                       QRJ.430
       F(I,NQNOPK)=F(I,NQNOPK)+BETA9(I,1)*.5*(F(I,NPNOK)+F(I,NPNOK-1))       QRJ.431
     1             *S5(I,1)/RMNO                                             QRJ.432
      ENDDO                                                                  QRJ.433
      DO K=1,KMAXP1                                                          QRJ.434
       FACTOR=C(85)*C(81)/C(57)*EXPS(1)*C(86)**(2*K-3)                       QRJ.435
       DO I=1,LEN1                                                           QRJ.436
        S8(I,K)=FACTOR/((S1(I,K)/RMASS(1)+S2(I,K)/RMASS(2)+                  QRJ.437
     1          S3(I,K)/RMASS(3))*S6(I,K))                                   QRJ.438
       ENDDO                                                                 QRJ.439
      ENDDO                                                                  QRJ.440
      DO I=1,LEN3                                                            QRJ.441
       S8(I,1)=S8(I,1)*(QUENCH(1)*S3(I,1)/RMASS(3)+                          QRJ.442
     1         QUENCH(2)*S1(I,1)/RMASS(1))                                   QRJ.443
       S8(I,1)=QUENCH(3)*S8(I,1)/(QUENCH(4)+S8(I,1))                         QRJ.444
      ENDDO                                                                  QRJ.445
      NQK=NQ                                                                 QRJ.446
      NRJK=NRJ                                                               QRJ.447
C     ****                                                                   QRJ.448
C     ****      S7=SUM OVER WAVE LENGTH(SIGMA*F*EXP(-SIGMA*CHAPMAN)*         QRJ.449
C     ****      (HC/LAMDA-DO2))                                              QRJ.450
C     ****      INITIALIZE S7                                                QRJ.451
C     ****                                                                   QRJ.452
      DO I=1,LEN3                                                            QRJ.453
       S7(I,1)=0.                                                            QRJ.454
      ENDDO                                                                  QRJ.455
C     ****                                                                   QRJ.456
C     ****      SUMMATION OVER WAVE LENGTH                                   QRJ.457
C     ****                                                                   QRJ.458
      NNO2K=NNO2                                                             QRJ.459
      DO N=1,15                                                              QRJ.460
       DO I=1,LEN3                                                           QRJ.461
        S9(I,1)=SIGSRC(N)*FSRC(N)*DEXP(-SIGSRC(N)*F(I,NNO2K))                QRJ.462
        S7(I,1)=S7(I,1)+S9(I,1)*(C(60)/RLMSRC(N)-DO22+S8(I,1))               QRJ.463
C       ****                                                                 QRJ.464
C       ****      UPDATE RJ                                                  QRJ.465
C       ****                                                                 QRJ.466
        F(I,NRJK)=F(I,NRJK)+S9(I,1)                                          QRJ.467
       ENDDO                                                                 QRJ.468
      ENDDO                                                                  QRJ.469
C     ****                                                                   QRJ.470
C     ****      UPDATE Q                                                     QRJ.471
C     ****                                                                   QRJ.472
      DO I=1,LEN3                                                            QRJ.473
       F(I,NQK)=F(I,NQK)+S7(I,1)*C(85)*S1(I,1)/RMASS(1)                      QRJ.474
      ENDDO                                                                  QRJ.475
C     ****                                                                   QRJ.476
C     ****      CONTRIBUTIONS FROM SCHUMANN RUNGE BANDS                      QRJ.477
C     ****      S7=P3*F                                                      QRJ.478
C     ****                                                                   QRJ.479
      NNO2K=NNO2                                                             QRJ.480
      DO I=1,LEN3                                                            QRJ.481
       CVMG=F(I,NNO2K)-1.D18                                                 QRJ.482
       IF(CVMG.GE.0.)THEN                                                    QRJ.483
        S7(I,1)=1./(ABAND*F(I,NNO2K)+BBAND*DSQRT(F(I,NNO2K)))*               QRJ.484
     1          (1.+0.11*(C(61)-65.)/165.)                                   QRJ.485
       ELSE                                                                  QRJ.486
        S7(I,1)=CBAND*(1.+0.11d0*(C(61)-65)/165)                             QRJ.487
       ENDIF                                                                 QRJ.488
       F(I,NQK)=F(I,NQK)+S7(I,1)*C(85)*S1(I,1)/RMASS(1)*E3                   QRJ.489
       F(I,NRJK)=F(I,NRJK)+S7(I,1)/DO2                                       QRJ.490
      ENDDO                                                                  QRJ.491
      RETURN                                                                 QRJ.492
      END                                                                    QRJ.493
C                                                                            QRJ.494
*DK QTIEFF                                                                QTIEFF.1
      SUBROUTINE QTIEFF                                                   QTIEFF.2
C     ****                                                                QTIEFF.3
C     ****     CALCULATES ELECTRON PRODUCTION OF N4S AND N2D IN NQTEF     QTIEFF.4
C     ****                                                                QTIEFF.5
      INCLUDE 'param.h'                                                   QTIEFF.6
      INCLUDE 'const.h'                                                   QTIEFF.7
      INCLUDE 'index.h'                                                   QTIEFF.8
C     ****                                                                QTIEFF.9
C     ****     ADD NQN2P TO NQTEF                                         QTIEFF.10
C     ****                                                                QTIEFF.11
      NQN2PK=NQN2P                                                        QTIEFF.12
      NQTEFK=NQTEF                                                        QTIEFF.13
      DO I=1,LEN3                                                         QTIEFF.14
       F(I,NQTEFK)=F(I,NQTEFK)+1.57*F(I,NQN2PK)                           QTIEFF.15
      ENDDO                                                               QTIEFF.16
      RETURN                                                              QTIEFF.17
      END                                                                 QTIEFF.18
C                                                                         QTIEFF.19
*DK RATES                                                                  RATES.1
      SUBROUTINE RATES                                                     RATES.2
C     ****                                                                 RATES.3
C     ****     COMPUTES NEEDED REACTION RATES IN COMMON BLOCK/RATES/       RATES.4
C     ****                                                                 RATES.5
      INCLUDE 'param.h'                                                    RATES.6
      INCLUDE 'vscrw.h'                                                    RATES.7
      INCLUDE 'const.h'                                                    RATES.8
      INCLUDE 'index.h'                                                    RATES.9
      INCLUDE 'buffe.h'                                                    RATES.10
      INCLUDE 'phycs.h'                                                    RATES.11
      INCLUDE 'rates.h'                                                    RATES.12
      NTEK=NJ+NTE                                                          RATES.13
      NTIK=NJ+NTI                                                          RATES.14
      NTK=NJ+NT                                                            RATES.15
      NNO2K=NNO2                                                           RATES.16
      NNVO2K=NNVO2                                                         RATES.17
      DO I=1,LEN2                                                          RATES.18
C      ****                                                                RATES.19
C      ****     S15 = T1/300.    S14 = T2/300.    S13 = TR/300.            RATES.20
C      ****                                                                RATES.21
       S15(I,1)=(0.667*F(I,NTIK)+0.333*F(I,NTK))/300.                      RATES.22
       S14(I,1)=(0.6363*F(I,NTIK)+0.3637*F(I,NTK))/300.                    RATES.23
       S13(I,1)=.5*(F(I,NTIK)+F(I,NTK))/300.                               RATES.24
C      ****                                                                RATES.25
C      ****     K1   (ASSUMES T1/300 IN S15)                               RATES.26
C      ****                                                                RATES.27
       RK1(I,1,1)=(((9.65D-16*S15(I,1)-5.17D-14)*S15(I,1)+1.073D-12)*      RATES.28
     1            S15(I,1)-7.74D-12)*S15(I,1)+2.82D-11                     RATES.29
C      ****                                                                RATES.30
C      ****     K2   (ASSUMES T2/300 IN S14)                               RATES.31
C      ****                                                                RATES.32
       RK2(I,1)=(8.6D-14*S14(I,1)-5.92D-13)*S14(I,1)+1.533D-12             RATES.33
C      ****                                                                RATES.34
C      ****     K3   (ASSUMES TR/300 IN S13)                               RATES.35
C      ****                                                                RATES.36
       IF((300.*S13(I,1)-1500.).GE.0.)THEN                                 RATES.37
        RK3(I,1)=5.2D-11*S13(I,1)**0.2                                     RATES.38
       ELSE                                                                RATES.39
        RK3(I,1)=1.4D-10*S13(I,1)**(-0.44)                                 RATES.40
       ENDIF                                                               RATES.41
C      ****                                                                RATES.42
C      ****     K4 THRU K10                                                RATES.43
C      ****                                                                RATES.44
       RK4(I,1)=1.0D-10                                                    RATES.45
       RK5(I,1)=4.4D-10                                                    RATES.46
       RK6(I,1)=4.0D-10                                                    RATES.47
       RK7(I,1)=2.0D-10                                                    RATES.48
       RK8(I,1)=1.0D-12                                                    RATES.49
       RK9(I,1)=6.0D-11                                                    RATES.50
       RK10(I,1)=1.3D-10                                                   RATES.51
       RK16(I,1) = 4.8D-10                                                 RATES.52
       RK17(I,1) = 1.0D-10                                                 RATES.53
       RK18(I,1) = 4.0D-10                                                 RATES.54
       RK19(I,1) = 4.0D-8*DSQRT(300/F(I,NTEK))                             RATES.55
       RK20(I,1) = 1.5D-7*DSQRT(300/F(I,NTEK))                             RATES.56
       RK21(I,1) = 0.047                                                   RATES.57
       RK22(I,1) = 0.171                                                   RATES.58
       RK23(I,1) = 8.D-10                                                  RATES.59
       RK24(I,1) = 5.0D-12                                                 RATES.60
       RK25(I,1) = 6.6D-8*DSQRT(300/F(I,NTEK))                             RATES.61
       RK26(I,1) = 7.D-10                                                  RATES.62
       RK27(I,1) = 7.7D-5                                                  RATES.63
       RKM12(I,1) = 9.59D-34*DEXP(480/F(I,NTK))                            RATES.64
C      ****                                                                RATES.65
C      ****     RATES ALF1 THRU ALF3 (INVOLVE ELECTRON TEMPERATURE AND     RATES.66
C      ****     ASSUME NTEK HAS APPROPRIATE VALUE)                         RATES.67
C      ****                                                                RATES.68
       RA1(I,1)=4.2D-7*(300./F(I,NTEK))**0.85                              RATES.69
       IF((F(I,NTEK)-1200.).GE.0.0)THEN                                    RATES.70
        RA2(I,1)=1.6D-7*(300./F(I,NTEK))**0.55                             RATES.71
       ELSE                                                                RATES.72
        RA2(I,1)=2.7D-7*(300./F(I,NTEK))**0.70                             RATES.73
       ENDIF                                                               RATES.74
       RA3(I,1)=1.8D-7*(300./F(I,NTEK))**0.39                              RATES.75
       BETA1(I,1)=1.5D-11*DEXP(-3600./F(I,NTK))                            RATES.76
       BETA2(I,1)=5.0D-12                                                  RATES.77
       BETA3(I,1)=2.5D-10*DSQRT(F(I,NTK)/300.)*DEXP(-600./F(I,NTK))        RATES.78
C      ****                                                                RATES.79
C      ****     SET BETA4                                                  RATES.80
C      ****                                                                RATES.81
       BETA4(I,1)=6.9D-13                                                  RATES.82
C      ****                                                                RATES.83
C      ****     MIGHT BE OF FORM :                                         RATES.84
C      ****     BETA4 = FUNCTION(T)                                        RATES.85
C      ****     IN CODE THIS WOULD BE                                      RATES.86
C      ****     BETA4(I,1)=FUNCTION(F(I,NTK))                              RATES.87
C      ****                                                                RATES.88
       BETA5(I,1)=3.6D-10*DSQRT(F(I,NTEK)/300.)                            RATES.89
       BETA6(I,1)=7.0D-11                                                  RATES.90
       BETA7(I,1)=1.06D-5                                                  RATES.91
       BETA8(I,1)=4.5D-6*(1.+0.11*(C(61)-65.)/165.)*DEXP(-1.D-8*           RATES.92
     1            F(I,NNO2K)**0.38)                                        RATES.93
       BETA9(I,1)=2.91D11*(1.+0.2*(C(61)-65.)/100.)*2.D-18*DEXP(-8.D-21*   RATES.94
     1            F(I,NNO2K))                                              RATES.95
       BETA9N(I,1)=5.D9*(1.+0.2*(C(61)-65.)/100.)*2.D-18*DEXP(-8.D-21*     RATES.96
     1             F(I,NNVO2K))                                            RATES.97
       BETA17(I,1)=1.D-32*DSQRT(300./F(I,NTEK))                            RATES.98
      ENDDO                                                                RATES.99
      DO I=1,LEN1                                                          RATES.100
       BETA8(I,KMAXP1)=4.5D-6*(1.+0.11*(C(61)-65.)/165.)*DEXP(-1.D-8*      RATES.101
     1                 F(I,NNO2K+KMAX)**0.38)                              RATES.102
       BETA9(I,KMAXP1)=2.91D11*(1.+0.2*(C(61)-65.)/100.)*2.D-18*           RATES.103
     1                 DEXP(-8.D-21*F(I,NNO2K+KMAX))                       RATES.104
       BETA9N(I,KMAXP1)=5.D9*(1.+0.2*(C(61)-65.)/100.)*2.D-18*             RATES.105
     1                  DEXP(-8.D-21*F(I,NNVO2K+KMAX))                     RATES.106
      ENDDO                                                                RATES.107
      RETURN                                                               RATES.108
      END                                                                  RATES.109
C                                                                          RATES.110
*DK ROTATE                                                                ROTATE.1
      SUBROUTINE ROTATE                                                   ROTATE.2
C     ****                                                                ROTATE.3
C     ****     ROTATES LAMDAS                                             ROTATE.4
C     ****                                                                ROTATE.5
      INCLUDE 'param.h'                                                   ROTATE.6
      INCLUDE 'vscrw.h'                                                   ROTATE.7
      INCLUDE 'const.h'                                                   ROTATE.8
      INCLUDE 'index.h'                                                   ROTATE.9
      INCLUDE 'phycs.h'                                                   ROTATE.10
      COMMON/TRGM/RLATM(ZIMXP,ZJMX),RLONM(ZIMXP,ZJMX),                    ROTATE.11
     1      DIPMAG(ZIMXP,ZJMX),DECMAG(ZIMXP,ZJMX),SNDEC(ZIMXP,ZJMX),      ROTATE.12
     2      CSDEC(ZIMXP,ZJMX),SN2DEC(ZIMXP,ZJMX),SNCSDC(ZIMXP,ZJMX),      ROTATE.13
     3      RLATMP(ZJMX),RLONMP(ZJMX),DLONS(ZJMX)                         ROTATE.14
      NLXXK=NLXX-1                                                        ROTATE.15
      NLYYK=NLYY-1                                                        ROTATE.16
      NLXYK=NLXY-1                                                        ROTATE.17
      NLYXK=NLYX-1                                                        ROTATE.18
      DO K=1,KMAXP1                                                       ROTATE.19
       NLXXK=NLXXK+1                                                      ROTATE.20
       NLYYK=NLYYK+1                                                      ROTATE.21
       NLXYK=NLXYK+1                                                      ROTATE.22
       NLYXK=NLYXK+1                                                      ROTATE.23
       DO I=1,IMAXP4                                                      ROTATE.24
C       ****                                                              ROTATE.25
C       ****     S1=LAMXX, S2=LAMYY                                       ROTATE.26
C       ****                                                              ROTATE.27
        S1(I,K)=F(I,NLXXK)*(1.-SN2DEC(I,J))+F(I,NLYYK)*SN2DEC(I,J)        ROTATE.28
        S2(I,K)=F(I,NLYYK)*(1.-SN2DEC(I,J))+F(I,NLXXK)*SN2DEC(I,J)        ROTATE.29
C       ****                                                              ROTATE.30
C       ****     LAMYX, LAMXY, LAMXX, LAMYY                               ROTATE.31
C       ****                                                              ROTATE.32
        F(I,NLYXK)=F(I,NLXYK)-(F(I,NLYYK)-F(I,NLXXK))*SNCSDC(I,J)         ROTATE.33
        F(I,NLXYK)=F(I,NLXYK)+(F(I,NLXXK)-F(I,NLYYK))*SNCSDC(I,J)         ROTATE.34
        F(I,NLXXK)=S1(I,K)                                                ROTATE.35
        F(I,NLYYK)=S2(I,K)                                                ROTATE.36
       ENDDO                                                              ROTATE.37
      ENDDO                                                               ROTATE.38
C     ****                                                                ROTATE.38
C     ****     PERIODIC POINTS FOR LAMDAS                                 ROTATE.39
C     ****                                                                ROTATE.40
      NLXXK=NLXX-1                                                        ROTATE.41
      DO I=1,2                                                            ROTATE.42
       DO K=1,4*KMAXP1                                                    ROTATE.43
        F(I,NLXXK+K)=F(I+IMAX,NLXXK+K)                                    ROTATE.44
        F(I+IMAXP2,NLXXK+K)=F(I+2,NLXXK+K)                                ROTATE.45
       ENDDO                                                              ROTATE.46
      ENDDO                                                               ROTATE.47
      RETURN                                                              ROTATE.48
      END                                                                 ROTATE.49
C                                                                         ROTATE.50
*DK RRK                                                                      RRK.1
      SUBROUTINE RRK(T,RMS,PS1,PS2,TP,ANS)                                   RRK.2
C     ****                                                                   RRK.3
C     ****      EVALUATES  ANS = K (DIFFUSION COEFFICIENT)                   RRK.4
C     ****                                                                   RRK.5
      INCLUDE 'param.h'                                                      RRK.6
      INCLUDE 'const.h'                                                      RRK.7
      COMMON/MASS/RMN4S,RMN2D,RMNO,BRN2D,CEE                                 RRK.8
      DIMENSION T(ZIMXP,ZKMXP),RMS(ZIMXP,ZKMXP),PS1(ZIMXP,ZKMXP),            RRK.9
     A          PS2(ZIMXP,ZKMXP),TP(ZIMXP,ZKMXP),ANS(ZIMXP,ZKMXP)            RRK.10
C     ****                                                                   RRK.11
C     ****      SET UP EXPS ARRAY                                            RRK.12
C     ****                                                                   RRK.13
      CEE=1.50                                                               RRK.14
      DO K=1,KMAX                                                            RRK.15
       DO I=1,LEN1                                                           RRK.16
        ANS(I,K)=EXPS(K)                                                     RRK.17
       ENDDO                                                                 RRK.18
      ENDDO                                                                  RRK.19
      DO I=1,LEN2                                                            RRK.20
       ANS(I,1)=1.42D17*C(84)*T(I,1)/(C(81)*ANS(I,1)*.5*(RMS(I,1)+           RRK.21
     1          RMS(I,2))*(PS2(I,1)/RMASS(2)*DSQRT(TP(I,1))*(1.-0.064*       RRK.22
     2          DLOG10(TP(I,1)))**2*CEE+18.6*(1.-PS1(I,1)-PS2(I,1))/         RRK.23
     3          RMASS(3)+18.1*PS1(I,1)/RMASS(1)))                            RRK.24
      ENDDO                                                                  RRK.25
      RETURN                                                                 RRK.26
      END                                                                    RRK.27
C                                                                            RRK.28
*DK SETTEI                                                                SETTEI.1
      SUBROUTINE SETTEI                                                   SETTEI.2
C     ****                                                                SETTEI.3
C     ****     CALCULATE ELECTRON AND ION TEMPERATURES                    SETTEI.4
C     ****                                                                SETTEI.5
      INCLUDE 'param.h'                                                   SETTEI.6
      INCLUDE 'vscrw.h'                                                   SETTEI.7
      INCLUDE 'const.h'                                                   SETTEI.8
      INCLUDE 'index.h'                                                   SETTEI.9
      INCLUDE 'start.h'                                                   SETTEI.10
      INCLUDE 'buffe.h'                                                   SETTEI.11
      INCLUDE 'phycs.h'                                                   SETTEI.12
      INCLUDE 'rates.h'                                                   SETTEI.13
      COMMON/TRGM/RLATM(ZIMXP,ZJMX),RLONM(ZIMXP,ZJMX),                    SETTEI.14
     1      DIPMAG(ZIMXP,ZJMX),DECMAG(ZIMXP,ZJMX),SNDEC(ZIMXP,ZJMX),      SETTEI.15
     2      CSDC(ZIMXP,ZJMX),SN2DEC(ZIMXP,ZJMX),SNCSDC(ZIMXP,ZJMX),       SETTEI.16
     3      RLATMP(ZJMX),RLONMP(ZJMX),DLONS(ZJMX)                         SETTEI.17
      common/maxte/temax
C     ****                                                                SETTEI.18
C     ****     SMALL NUMBER DELTA                                         SETTEI.19
C     ****                                                                SETTEI.20
      DATA DEL/1.D-6/                                                     SETTEI.21
C     ****                                                                SETTEI.22
C     ****     CORRECTION FACTOR FOR NEUTRAL HEATING DUE TO L(E,O1D)      SETTEI.23
C     ****                                                                SETTEI.24
      DATA ALAM,AD,SD/0.0069,0.0091,2.3D-11/                              SETTEI.25
C     ****                                                                SETTEI.26
C     ****     CONVERSION FROM EV TO ERGS                                 SETTEI.27
C     ****                                                                SETTEI.28
      DATA EVTERG/1.602D-12/                                              SETTEI.29
C     ****                                                                SETTEI.30
C     ****     CONVERSION RADIANS TO DEGREES                              SETTEI.31
C     ****                                                                SETTEI.32
      RTD=180.d0/C(110)                                                   SETTEI.33
C     ****                                                                SETTEI.34
C     ****     SQRT(2.)                                                   SETTEI.35
C     ****                                                                SETTEI.36
      ROOT2 = DSQRT(2.D0)                                                 SETTEI.37
C     ****                                                                SETTEI.38
C     ****     CALCULATE HEAT FLUX, FE, AT UPPER BOUNDARY                 SETTEI.39
      F107TE=C(61)                                                        SETTEI.40
      IF (F107TE.GT.235.)F107TE=235.                                      SETTEI.41
C     ****                                                                SETTEI.42
C     ****     CALCULATE SOLAR ZENITH ANGLE, CHI                          SETTEI.43
C     ****                                                                SETTEI.44
      RLAT=-.5*C(110)*DBLE(1-NHEMI)+(DBLE(J-1)+.5)*C(2)                   SETTEI.45
      COSLAT=DCOS(RLAT)                                                   SETTEI.46
      SINLAT=DSIN(RLAT)                                                   SETTEI.47
      DO I=1,LEN1                                                         SETTEI.48
C      ****                                                               SETTEI.49
C      ****     T2 = LOCAL TIME                                           SETTEI.50
C      ****                                                               SETTEI.51
      T2(I)=DMOD(SECS/3600.+(DBLE(I-3)*C(1)+C(110))*12./C(110),24.D0)       SETTEI.52
C      ****                                                               SETTEI.53
C      ****     T2 = CHI                                                  SETTEI.54
C      ****                                                               SETTEI.55
       T2(I)=DACOS(C(95)*SINLAT+C(96)*COSLAT*DCOS(C(110)*(T2(I)-12.)      SETTEI.56
     1       /12.d0))                                                     SETTEI.57
C      ****                                                               SETTEI.58
C      ****     T3 = A = .5*(1.+SIN(PI*(ABS(RLATM)-PI/6.)/(PI/3.)))       SETTEI.59
C      ****               FOR  ABS(RLATM).LT.PI/3.                        SETTEI.60
C      ****          A = 1.    FOR  ABS(RLATM).GE.PI/3                    SETTEI.61
C      ****                                                               SETTEI.62
       IF((DABS(RLATM(I,J))-C(110)/4.5).GE.0.)THEN                        SETTEI.63
        T3(I)=1.                                                          SETTEI.64
       ELSE                                                               SETTEI.65
        T3(I)=.5*(1+DSIN(C(110)*(DABS(RLATM(I,J))-C(110)/9.)              SETTEI.66
     1        /(C(110)/4.5)))                                             SETTEI.67
       ENDIF                                                              SETTEI.68
C      ****                                                               SETTEI.69
C      ****     T4 = FED       T5 = FEN                                   SETTEI.70
C      ****                                                               SETTEI.71
       T4(I)=(-4.5D7*F107TE*T3(I)-4.0D7*F107TE)/4.                        SETTEI.72
       T5(I)=T4(I)/3.                                                     SETTEI.73
C      ****                                                               SETTEI.74
C      ****     T1 = FE                                                   SETTEI.75
C      ****                                                               SETTEI.76
       IF((T2(I)-.5*C(110)).GE.0.)THEN                                    SETTEI.77
        T1(I)=T5(I)                                                       SETTEI.78
       ELSE                                                               SETTEI.79
        T1(I)=T4(I)                                                       SETTEI.80
       ENDIF                                                              SETTEI.81
       IF(((T2(I)*RTD-80.)*(T2(I)*RTD-100.)).GE.0.0)THEN                  SETTEI.82
        T1(I)=T1(I)*EVTERG                                                SETTEI.83
       ELSE                                                               SETTEI.84
        T1(I)=(.5*(T4(I)+T5(I))+.5*(T4(I)-T5(I))                          SETTEI.85
     1        *DCOS(C(110)*(T2(I)*RTD-80.)/20.))*EVTERG                   SETTEI.86
       ENDIF                                                              SETTEI.87
      ENDDO                                                               SETTEI.88
C     ****                                                                SETTEI.89
C     ****     CALCULATE K0 = KE/TE**2.5           (K)                    SETTEI.90
C     ****                                                                SETTEI.91
      NTEK=NJ+NTE                                                         SETTEI.92
      NEK=NJ+NE                                                           SETTEI.93
      NPS1K=NJ+NPS                                                        SETTEI.94
      NPS2K=NJ+NPS2                                                       SETTEI.95
      NTK=NJ+NT                                                           SETTEI.96
C     ****                                                                SETTEI.97
C     ****     CALCULATE TE, PSI(O2), PSI(O), PSI(N2), T    (K)           SETTEI.98
C     ****                                                                SETTEI.99
C     ****     LEVELS 2 THRU KMAX                                         SETTEI.100
C     ****                                                                SETTEI.101
      DO I=LEN1+1,LEN2                                                    SETTEI.102
       S14(I,1)=.5*(F(I,NTEK)+F(I,NTEK-1))                                SETTEI.103
       S13(I,1)=.5*(F(I,NPS1K)+F(I,NPS1K-1))                              SETTEI.104
       S12(I,1)=.5*(F(I,NPS2K)+F(I,NPS2K-1))                              SETTEI.105
       S10(I,1)=.5*(F(I,NTK)+F(I,NTK-1))                                  SETTEI.106
      ENDDO                                                               SETTEI.107
C     ****                                                                SETTEI.108
C     ****     LEVELS 1 AND KMAXP1                                        SETTEI.109
C     ****                                                                SETTEI.110
      DO I=1,LEN1                                                         SETTEI.111
       S14(I,1)=1.5*F(I,NTEK)-.5*F(I,NTEK+1)                              SETTEI.112
       S13(I,1)=1.5*F(I,NPS1K)-.5*F(I,NPS1K+1)                            SETTEI.113
       S12(I,1)=1.5*F(I,NPS2K)-.5*F(I,NPS2K+1)                            SETTEI.114
       S10(I,1)=1.5*F(I,NTK)-.5*F(I,NTK+1)                                SETTEI.115
       S14(I,KMAXP1)=1.5*F(I,NTEK+KMAXM1)-.5*F(I,NTEK+KMAX-2)             SETTEI.116
       S13(I,KMAXP1)=1.5*F(I,NPS1K+KMAXM1)-.5*F(I,NPS1K+KMAX-2)           SETTEI.117
       S12(I,KMAXP1)=1.5*F(I,NPS2K+KMAXM1)-.5*F(I,NPS2K+KMAX-2)           SETTEI.118
       S10(I,KMAXP1)=1.5*F(I,NTK+KMAXM1)-.5*F(I,NTK+KMAX-2)               SETTEI.119
      ENDDO                                                               SETTEI.120
C     ****                                                                SETTEI.121
C     ****     S11 = PSI(N2)                                              SETTEI.122
C     ****                                                                SETTEI.123
      DO I=1,LEN3                                                         SETTEI.124
       S11(I,1)=1-S12(I,1)-S13(I,1)                                       SETTEI.125
       IF(S11(I,1).LT.0.)S11(I,1)=0.                                      SETTEI.126
      ENDDO                                                               SETTEI.127
C     ****                                                                SETTEI.128
C     ****     S9 = EXP(-Z)                       (K)                     SETTEI.129
C     ****                                                                SETTEI.130
C     ****     LEVELS 1 THRU KMAX                                         SETTEI.131
C     ****                                                                SETTEI.132
      DO K=1,KMAX                                                         SETTEI.133
       EXPSK=C(87)*EXPS(K)                                                SETTEI.134
       DO I=1,LEN1                                                        SETTEI.135
        S9(I,K)=EXPSK                                                     SETTEI.136
       ENDDO                                                              SETTEI.137
      ENDDO                                                               SETTEI.138
C     ****                                                                SETTEI.139
C     ****     LEVEL KMAXP1                                               SETTEI.140
C     ****                                                                SETTEI.141
      EXPSK=C(86)*EXPS(KMAX)                                              SETTEI.142
      DO I=1,LEN1                                                         SETTEI.143
       S9(I,KMAXP1)=EXPSK                                                 SETTEI.144
      ENDDO                                                               SETTEI.145
C     ****                                                                SETTEI.146
C     ****                                                                SETTEI.147
C     ****     S13 = N(O2), S12 = N(O), S11 = N(N2)         (K)           SETTEI.148
C     ****                                                                SETTEI.149
      NMSK=NJ+NMS                                                         SETTEI.150
      DO I=1,LEN3                                                         SETTEI.151
C      ****                                                               SETTEI.152
C      ****     S8 = P0*EXP(-Z)*MBAR/(K*T)                   (K)          SETTEI.153
C      ****                                                               SETTEI.154
       S8(I,1)=C(81)*S9(I,1)*F(I,NMSK)/(C(84)*S10(I,1))                   SETTEI.155
       S13(I,1)=S8(I,1)*S13(I,1)/RMASS(1)                                 SETTEI.156
       S12(I,1)=S8(I,1)*S12(I,1)/RMASS(2)                                 SETTEI.157
       S11(I,1)=S8(I,1)*S11(I,1)/RMASS(3)                                 SETTEI.158
C      ****                                                               SETTEI.159
C      ****   S5 = SQRT(TE)                                               SETTEI.157
C      ****                                                               SETTEI.158
       IF(S14(I,1).LE.50.)S14(I,1)=50.                                    SETTEI.159
       S5(I,1) = DSQRT(S14(I,1))                                          SETTEI.160
C      ****                                                               SETTEI.161
C      ****   S15 = K0                                                    SETTEI.162
C      ****                                                               SETTEI.163
       S15(I,1)=7.5D5/(1.+3.22D4*S14(I,1)**2/F(I,NEK)*(S5(I,1)            SETTEI.164
     1          *(2.82D-17-3.41D-21*S14(I,1))*S11(I,1)+(2.2D-16+          SETTEI.165
     2          7.92D-18*S5(I,1))*S13(I,1)+1.1D-16*(1.+5.7D-4*            SETTEI.166
     3          S14(I,1))*S12(I,1)))*EVTERG                               SETTEI.167
      ENDDO                                                               SETTEI.168
C     ****                                                                SETTEI.169
C     ****     S7 = H         (K+1/2)                                     SETTEI.170
C     ****     S6 = H         (K)                                         SETTEI.171
C     ****                                                                SETTEI.172
      DO I=1,LEN2                                                         SETTEI.173
       S7(I,1)=C(57)*F(I,NTK)/(.5*(F(I,NMSK)+F(I,NMSK+1))*C(54))          SETTEI.174
      ENDDO                                                               SETTEI.175
      DO I=1,LEN3                                                         SETTEI.176
       S6(I,1)=C(57)*S10(I,1)/(F(I,NMSK)*C(54))                           SETTEI.177
      ENDDO                                                               SETTEI.178
C     ****                                                                SETTEI.179
C     ****     S1 = P, S3 = R, S2 = -(P+R), S4 = 0.         (K+1/2)       SETTEI.180
C     ****                                                                SETTEI.181
C     ****     T2 = (SIN(DIPMAG))**2                                      SETTEI.182
C     ****                                                                SETTEI.183
      DO I=1,LEN1                                                         SETTEI.184
       T2(I)=(DSIN(DIPMAG(I,J)))**2                                       SETTEI.185
       IF((T2(I)-.01).LT.0.)T2(I)=.01                                     SETTEI.186
      ENDDO                                                               SETTEI.187
C     ****                                                                SETTEI.188
C     ****     S2 = T2                                                    SETTEI.189
C     ****                                                                SETTEI.190
      DO K=1,KMAX                                                         SETTEI.191
       DO I=1,LEN1                                                        SETTEI.192
        S2(I,K)=T2(I)                                                     SETTEI.193
       ENDDO                                                              SETTEI.194
      ENDDO                                                               SETTEI.195
      DO I=1,LEN2                                                         SETTEI.196
C      ****                                                               SETTEI.197
C      ****   S1 = 2./7.*(SIN(I))**2/(H*DZ**2)        (K)                 SETTEI.198
C      ****                                                               SETTEI.199
       S1(I,1)=2./7.*S2(I,1)/(S7(I,1)*C(3)**2)                            SETTEI.200
       S3(I,1)=S1(I,1)*S15(I,2)/S6(I,2)                                   SETTEI.201
       S1(I,1)=S1(I,1)*S15(I,1)/S6(I,1)                                   SETTEI.202
       S2(I,1)=-(S1(I,1)+S3(I,1))                                         SETTEI.203
       S4(I,1)=0.                                                         SETTEI.204
      ENDDO                                                               SETTEI.205
C     ****                                                                SETTEI.206
C     ****      BOUNDARY CONDITIONS                                       SETTEI.207
C     ****                                                                SETTEI.208
      DO I=1,LEN1                                                         SETTEI.209
C      ****                                                               SETTEI.210
C      ****   LOWER BOUNDARY                                              SETTEI.211
C      ****                                                               SETTEI.212
       S2(I,1)=S2(I,1)-S1(I,1)                                            SETTEI.213
       S4(I,1)=S4(I,1)-2*S1(I,1)*S10(I,1)**3.5d0                          SETTEI.214
       S1(I,1)=0.                                                         SETTEI.215
C      ****                                                               SETTEI.216
C      ****   UPPER BOUNDARY                                              SETTEI.217
C      ****                                                               SETTEI.218
       S2(I,KMAX)=S2(I,KMAX)+S3(I,KMAX)                                   SETTEI.219
       S4(I,KMAX)=S4(I,KMAX)+S3(I,KMAX)*C(3)*3.5d0*S6(I,KMAXP1)*T1(I)     SETTEI.220
     1            /S15(I,KMAXP1)                                          SETTEI.221
       S3(I,KMAX)=0.                                                      SETTEI.222
      ENDDO                                                               SETTEI.223
C     ****                                                                SETTEI.224
C     ****     S15 = NE, S14 = N(O2), S13 = N(O), S12 = N(N2)    (K+1/2)  SETTEI.225
C     ****     S11 = QI(TOT)                                     (K+1/2)  SETTEI.226
C     ****                                                                SETTEI.227
      NEK=NJ+NE                                                           SETTEI.228
      NPS1K=NJ+NPS                                                        SETTEI.229
      NPS2K=NJ+NPS2                                                       SETTEI.230
      NQPK=NQO2P                                                          SETTEI.231
      NTK=NJ+NT                                                           SETTEI.232
      NMSK=NJ+NMS                                                         SETTEI.233
      NTEK=NJ+NTE                                                         SETTEI.234
      NTIK=NJ+NTI                                                         SETTEI.235
      NOPK=NJ+NOP                                                         SETTEI.236
      NO2PK=NJ+NO2P                                                       SETTEI.237
      NNOPK=NNOP                                                          SETTEI.238
      DO I=1,LEN3                                                         SETTEI.239
       S11(I,1)=0.                                                        SETTEI.240
      ENDDO                                                               SETTEI.241
C     ****                                                                SETTEI.242
C     ****     S11 = QI(TOT), TOTAL IONIZATION RATE         (K+1/2)       SETTEI.243
C     ****                                                                SETTEI.244
      DO N=1,5                                                            SETTEI.245
       DO I=1,LEN3                                                        SETTEI.246
        S11(I,1)=S11(I,1)+F(I,NQPK)                                       SETTEI.247
        IF(s11(I,1).LT.1.D-20)S11(I,1)=1.D-20                             SETTEI.248
       ENDDO                                                              SETTEI.249
       NQPK=NQPK+KMAXP1                                                   SETTEI.250
      ENDDO                                                               SETTEI.251
      DO I=1,LEN3                                                         SETTEI.252
       S11(I,1)=S11(I,1)+QOP2P(I,1)+QOP2D(I,1)                            SETTEI.253
      ENDDO                                                               SETTEI.254
      DO I=1,LEN2                                                         SETTEI.255
       S11(I,1)=DSQRT(S11(I,1)*S11(I,2))                                  SETTEI.256
      ENDDO                                                               SETTEI.257
      DO I=1,LEN1                                                         SETTEI.258
       S11(I,KMAXP1)=0.                                                   SETTEI.259
      ENDDO                                                               SETTEI.260
C     ****                                                                SETTEI.261
C     ****     NOW SET NE     (K+1/2)                                     SETTEI.262
C     ****                                                                SETTEI.263
      DO I=1,LEN2                                                         SETTEI.264
       S10(I,1)=F(I,NEK)*F(I,NEK+1)                                       SETTEI.265
       IF(S10(I,1).LE.1.D4)S10(I,1)=1.D4                                  SETTEI.266
       S15(I,1)=DSQRT(S10(I,1))                                           SETTEI.267
      ENDDO                                                               SETTEI.268
C     ****                                                                SETTEI.269
C     ****     S10 = EXP(-Z)       (K+1/2)                                SETTEI.270
C     ****                                                                SETTEI.271
      DO K=1,KMAX                                                         SETTEI.272
       EXPSK=EXPS(K)                                                      SETTEI.273
       DO I=1,LEN1                                                        SETTEI.274
        S10(I,K)=EXPSK                                                    SETTEI.275
       ENDDO                                                              SETTEI.276
      ENDDO                                                               SETTEI.277
      DO I=1,LEN2                                                         SETTEI.278
C      ****                                                               SETTEI.279
C      ****   S6 = P0*EXP(-Z)*MBAR/(K*T)         (K+1/2)                  SETTEI.280
C      ****                                                               SETTEI.281
       S6(I,1)=C(81)*S10(I,1)*.5*(F(I,NMSK)+F(I,NMSK+1))/                 SETTEI.282
     1           (C(84)*F(I,NTK))                                         SETTEI.283
C      ****                                                               SETTEI.284
C      ****   S14 = N(O2),   S13 = N(O)          (K+1/2)                  SETTEI.285
C      ****                                                               SETTEI.286
       S14(I,1)=S6(I,1)*F(I,NPS1K)/RMASS(1)                               SETTEI.287
       S13(I,1)=S6(I,1)*F(I,NPS2K)/RMASS(2)                               SETTEI.288
C      ****                                                               SETTEI.289
C      ****   S12 = N(N2)         (K+1/2)                                 SETTEI.290
C      ****                                                               SETTEI.291
       S12(I,1)=1.-F(I,NPS1K)-F(I,NPS2K)                                  SETTEI.292
       IF(S12(I,1).LT.0.)S12(I,1)=0.                                      SETTEI.293
       S12(I,1)=S6(I,1)*S12(I,1)/RMASS(3)                                 SETTEI.294
C      ****                                                               SETTEI.295
C      ****   CALCULATE SOURCE TERM, QE          (K+1/2)                  SETTEI.296
C      ****                                                               SETTEI.297
C      ****   S10 = R        (K+1/2)                                      SETTEI.298
C      ****                                                               SETTEI.299
       S10(I,1)=DLOG(S15(I,1)/(S14(I,1)+S12(I,1)+0.1*S13(I,1)))           SETTEI.300
C      ****                                                               SETTEI.301
C      ****   S10 = E   (EFFICIENCY)        (K+1/2)                       SETTEI.302
C      ****                                                               SETTEI.303
       S10(I,1)=DEXP(-((((0.001996*S10(I,1)+0.08034)*S10(I,1)+1.166)      SETTEI.304
     1          *S10(I,1)+6.941)*S10(I,1)+12.75))                         SETTEI.305
C      ****                                                               SETTEI.306
C      ****   S4 = S4 - QE        (K+1/2)                                 SETTEI.307
C      ****                                                               SETTEI.308
       S4(I,1)=S4(I,1)-S10(I,1)*S11(I,1)*EVTERG           !!!             SETTEI.309
C      ****                                                               SETTEI.310
C      ****   S11 = L0(E,N) = L(E,N)/(TE-TN)       (K+1/2)                SETTEI.311
C      ****   S8 = L0*(E,N) = L*(E,N)/(TE-TN)       (K+1/2)               SETTEI.312
C      ****                                                               SETTEI.313
C      ****   S5 = SQRT(TE)                 (K+1/2)                       SETTEI.314
C      ****                                                               SETTEI.315
       S5(I,1)=DSQRT(F(I,NTEK))                                           SETTEI.316
C      ****                                                               SETTEI.317
C      ****   S9 = A(E,N2,VIB)              (K+1/2)                       SETTEI.318
C      ****                                                               SETTEI.319
       IF((F(I,NTEK)-1000.).GE.0.)THEN                                    SETTEI.320
        S9(I,1)=2.D-7*DEXP(-4605.2/F(I,NTEK))                             SETTEI.321
       ELSE                                                               SETTEI.322
        S9(I,1)=5.71D-8*DEXP(-3352.6/F(I,NTEK))                           SETTEI.323
       ENDIF                                                              SETTEI.324
       IF((2000.-F(I,NTEK)).LT.0.)THEN                                    SETTEI.325
        S9(I,1)=2.53D-6*S5(I,1)*DEXP(-17620./F(I,NTEK))                   SETTEI.326
       ENDIF                                                              SETTEI.327
C      ****                                                               SETTEI.328
C      ****   S10 = (1.-EXP(3200.*(1./TE-1./TN))/(TE-TN)   (K+1/2)        SETTEI.329
C      ****     (SAFEGUARDED FOR ZERO (TE-TN))                            SETTEI.330
C      ****                                                               SETTEI.331
       S10(I,1)=3200.*(1./F(I,NTEK)-1./F(I,NTK))                          SETTEI.332
       S10(I,1)=DSIGN(DABS(S10(I,1))+DEL,S10(I,1))                        SETTEI.333
       S10(I,1)=-3200./(F(I,NTEK)*F(I,NTK))*(1.-DEXP(S10(I,1)))           SETTEI.334
     1          /S10(I,1)                                                 SETTEI.335
C      ****                                                               SETTEI.336
C      ****   S10 = L0(E,N2,VIB)/(NE*N(N2))      (K+1/2)                  SETTEI.337
C      ****                                                               SETTEI.338
       S10(I,1)=1.3D-4*S10(I,1)*S9(I,1)                                   SETTEI.339
      ENDDO                                                               SETTEI.340
      DO I=1,LEN2                                                         SETTEI.341
C      ****                                                               SETTEI.342
C      ****   S11 = (L0(E,N2)+L0(E,N2,ROT)+L0(E,N2,VIB))/NE               SETTEI.343
C      ****                                                               SETTEI.344
       S11(I,1)=S12(I,1)*(1.77D-19*(1.-1.21D-4*F(I,NTEK))*F(I,NTEK)       SETTEI.345
     1          +2.9D-14/S5(I,1)+S10(I,1))                                SETTEI.346
C      ****                                                               SETTEI.347
C      ****   S11 = S11+(L0(E,O2)+L0(E,O2,ROT)+L0(E,O2,VIB)/NE            SETTEI.348
C      ****                                                               SETTEI.349
       S11(I,1)=S11(I,1)+S14(I,1)*(1.21D-18*(1.+3.6D-2*S5(I,1))           SETTEI.350
     1            *S5(I,1)+6.9D-14/S5(I,1)+3.125D-21*F(I,NTEK)**2)        SETTEI.351
C      ****                                                               SETTEI.352
C      ****   S10 = L0(E,O,1D)/(NE*N(O))                                  SETTEI.353
C      ****                                                               SETTEI.354
       S10(I,1)=22713.*(1./F(I,NTEK)-1./F(I,NTK))                         SETTEI.355
       S10(I,1)=DSIGN(DABS(S10(I,1))+DEL,S10(I,1))                        SETTEI.356
       S10(I,1)=22713./(F(I,NTEK)*F(I,NTK))*(1.-DEXP(S10(I,1)))           SETTEI.357
     1          /S10(I,1)                                                 SETTEI.358
       S10(I,1)=1.57D-12*DEXP((2.4D4+0.3*(F(I,NTEK)-1500.)-1.947D-5       SETTEI.359
     1          *(F(I,NTEK)-1500.)*(F(I,NTEK)-4000.))*(F(I,NTEK)-         SETTEI.360
     2          3000.)/(3000.*F(I,NTEK)))*S10(I,1)                        SETTEI.361
C      ****                                                               SETTEI.362
C      ****   S11 = S11+(L0(E,O)+L0(E,O,F))/NE                            SETTEI.363
C      ****                                                               SETTEI.364
       S11(I,1)=S11(I,1)+S13(I,1)*(7.9D-19*(1.+5.7D-4*F(I,NTEK))          SETTEI.365
     1          *S5(I,1)+3.4D-12*(1.-7.D-5*F(I,NTEK))/F(I,NTK)*           SETTEI.366
     2          (150./F(I,NTEK)+0.4))                                     SETTEI.367
C      ****                                                               SETTEI.368
C      ****    S8 = L0*(E,N)                                              SETTEI.369
C      ****                                                               SETTEI.370
       S8(I,1)=(S11(I,1)+S13(I,1)*(1.-ALAM/(AD+SD*S12(I,1)))              SETTEI.371
     1         *S10(I,1))*S15(I,1)*EVTERG                                 SETTEI.372
C      ****                                                               SETTEI.373
C      ****    S11 = L0(E,N)                                              SETTEI.374
C      ****                                                               SETTEI.375
       S11(I,1)=(S11(I,1)+S13(I,1)*S10(I,1))*S15(I,1)*EVTERG              SETTEI.376
C      ****                                                               SETTEI.377
C      ****   CALCULATE L0(E,I) = L(E,I)/(TE-TI), WHERE L(E,I) IS LOSS    SETTEI.378
C      ****   DUE TO INTERACTIONS BETWEEN ELECTRONS AND IONS              SETTEI.379
C      ****                                                               SETTEI.380
       S10(I,1)=3.2D-8*S15(I,1)/(S5(I,1)*F(I,NTEK))*15.                   SETTEI.381
     1          *(F(I,NOPK)+0.5*F(I,NO2PK)+0.53*F(I,NNOPK))*EVTERG        SETTEI.382
C      ****                                                               SETTEI.383
C      S5 = SQRT(TN)      (K+1/2)                                         SETTEI.384
C      ****                                                               SETTEI.385
       S5(I,1)=DSQRT(F(I,NTK))                                            SETTEI.386
C      ****                                                               SETTEI.387
C      ****    S9 = L0(I,N) =L(I,N)/(TI-TN)                               SETTEI.388
C      ****                                                               SETTEI.389
       S9(I,1)=((6.6D-14*S12(I,1)+5.8D-14*S14(I,1)+0.21D-14*S13(I,1)      SETTEI.390
     1         *ROOT2*S5(I,1))*F(I,NOPK)+(5.45D-14*S14(I,1)+5.9D-         SETTEI.391
     2         14*S12(I,1)+4.5D-14*S13(I,1))*F(I,NNOPK)+(5.8D-14*         SETTEI.392
     3         S12(I,1)+4.4D-14*S13(I,1)+0.14D-14*S14(I,1)*S5(I,1))*      SETTEI.393
     4         F(I,NO2PK))*EVTERG                                         SETTEI.394
C      ****                                                               SETTEI.395
C      ****   COMPLETE TRIDIAGONAL MATRIX COEFFICIENTS AND RHS            SETTEI.396
C      ****                                                               SETTEI.397
C      ****   S2 = S2-(L0(E,N)+L0(E,I))/TE**2.5 = Q                       SETTEI.398
C      ****                                                               SETTEI.399
       S2(I,1)=S2(I,1)-(S11(I,1)+S10(I,1))/F(I,NTEK)**2.5                 SETTEI.400
C      ****                                                               SETTEI.401
C      ****   S4 = S4-L0(E,N)*TN-L0(E,I)*TI                               SETTEI.402
C      ****                                                               SETTEI.403
       S4(I,1)=S4(I,1)-S11(I,1)*F(I,NTK)-S10(I,1)*F(I,NTIK)               SETTEI.404
      ENDDO                                                               SETTEI.405
C     ****                                                                SETTEI.406
C     ****     CALCULATE HEATING DUE TO ELECTRON/NEUTRAL AND              SETTEI.407
C     ****     ELECTRON/ION COLLISIONS         (K)                        SETTEI.408
C     ****                                                                SETTEI.409
C     ****     UNITS ARE:  ERGS/SEC/GM                                    SETTEI.410
C     ****                                                                SETTEI.411
C     ****     S7 = HEATING IN ERGS/SEC/GM     (K+1/2)                    SETTEI.412
C     ****                                                                SETTEI.413
      DO I=1,LEN2                                                         SETTEI.414
       IF(F(I,NTEK).GT.F(I,NTIK))THEN                                     SETTEI.415
        S7(I,1)=S10(I,1)*(F(I,NTEK)-F(I,NTIK))                            SETTEI.416
       ELSE                                                               SETTEI.417
        S7(I,1)=0.                                                        SETTEI.418
       ENDIF                                                              SETTEI.419
       S7(I,1)=(S8(I,1)*(F(I,NTEK)-F(I,NTK))+S7(I,1))*C(85)/S6(I,1)       SETTEI.420
      ENDDO                                                               SETTEI.421
C     ****                                                                SETTEI.422
C     ****     ADD COLLISIONAL HEATING TO NQ FOR USE IN THERMODYNAMIC     SETTEI.423
C     ****     EQUATION                                                   SETTEI.424
C     ****                                                                SETTEI.425
      NQK=NQ                                                              SETTEI.426
C     ****                                                                SETTEI.427
C     ****     LEVELS 2 THRU KMAX                                         SETTEI.428
C     ****                                                                SETTEI.429
      DO I=1,LEN2-LEN1                                                    SETTEI.430
       F(I,NQK+1)=F(I,NQK+1)+.5*(S7(I,1)+S7(I,2))                         SETTEI.431
      ENDDO                                                               SETTEI.432
C     ****                                                                SETTEI.433
C     ****     LEVELS 1 AND KMAXP1                                        SETTEI.434
C     ****                                                                SETTEI.435
      DO I=1,LEN1                                                         SETTEI.436
      F(I,NQK)=F(I,NQK)+1.5*S7(I,1)-0.5*S7(I,2)                           SETTEI.437
      F(I,NQK+KMAX)=F(I,NQK+KMAX)+1.5*S7(I,KMAX)-0.5*S7(I,KMAXM1)         SETTEI.438
      ENDDO                                                               SETTEI.439
C     ****                                                                SETTEI.440
C     ****     S15 = RHO                                                  SETTEI.441
C     ****                                                                SETTEI.442
      DO I=1,LEN2                                                         SETTEI.443
       S15(I,1)=S6(I,1)/C(85)                                             SETTEI.444
      ENDDO                                                               SETTEI.445
C     ****                                                                SETTEI.446
C     ****     SOLVE TRIDIAGONAL SYSTEM,    S8 = G                        SETTEI.447
C     ****                                                                SETTEI.448
      NTEK=NJNP+NTE                                                       SETTEI.449
      CALL TRSOLV(S1,S2,S3,S4,S7,F(1,NTEK),LEN1,3,LEN1-2,KMAXP1,1,KMAX    SETTEI.450
     1,1)                                                                 SETTEI.451
C     ****                                                                SETTEI.452
C     ****     PERIODIC POINTS                                            SETTEI.453
C     ****                                                                SETTEI.454
      DO I=1,2                                                            SETTEI.455
       DO K=0,KMAXM1                                                      SETTEI.456
        F(I,NTEK+K)=F(I+IMAX,NTEK+K)                                      SETTEI.457
        F(I+IMAXP2,NTEK+K)=F(I+2,NTEK+K)                                  SETTEI.458
       ENDDO                                                              SETTEI.459
      ENDDO                                                               SETTEI.460
      NTK=NJ+NT                                                           SETTEI.461
      NTEK=NJNP+NTE                                                       SETTEI.462
      DO I=1,LEN2                                                         SETTEI.463
       IF(F(I,NTEK).LT.F(I,NTK))F(I,NTEK)=F(I,NTK)                        SETTEI.464
      ENDDO                                                               SETTEI.465
C     ****                                                                SETTEI.466
C     ****      TE = TE**(2./7.)                                          SETTEI.467
C     ****                                                                SETTEI.468
      DO K=0,KMAXM1                                                       SETTEI.469
       DO I=1,LEN1                                                        SETTEI.470
        F(I,NTEK+K)=F(I,NTEK+K)**(2./7.)                                  SETTEI.471
        if(F(I,NTEK+K).ge.4000.)F(I,NTEK+K)=4000.
       ENDDO                                                              SETTEI.472
      ENDDO                                                               SETTEI.473
C     ****                                                                SETTEI.474
C     ****     S7 = QJI  (ION JOULE HEATING)      (K+1/2)                 SETTEI.475
C     ****                                                                SETTEI.476
      NUIK=NUI                                                            SETTEI.477
      NVIK=NVI                                                            SETTEI.478
      NUK=NJ+NU                                                           SETTEI.479
      NVK=NJ+NV                                                           SETTEI.480
      NLXXK=NLXX                                                          SETTEI.481
      NLXYK=NLXY                                                          SETTEI.482
      NLYXK=NLYX                                                          SETTEI.483
      NLYYK=NLYY                                                          SETTEI.484
      NTIK=NJNP+NTI                                                       SETTEI.485
      NTEK=NJ+NTE                                                         SETTEI.486
      NTK=NJ+NT                                                           SETTEI.487
      DO I=1,LEN2                                                         SETTEI.488
C      ****                                                               SETTEI.489
C      ****     S6 = UI(K+1/2)                                            SETTEI.490
C      ****     S5 = VI(K+1/2)                                            SETTEI.491
C      ****                                                               SETTEI.492
       S6(I,1)=.5*(F(I,NUIK)+F(I,NUIK+1))                                 SETTEI.493
       S5(I,1)=.5*(F(I,NVIK)+F(I,NVIK+1))                                 SETTEI.494
C      ****                                                               SETTEI.495
C      ****     S7 = QJI                                                  SETTEI.496
C      ****                                                               SETTEI.497
       S7(I,1)=.5*((F(I,NLXXK)+F(I,NLXXK+1))*S6(I,1)*(S6(I,1)-F(I,NUK))   SETTEI.498
     1         +(F(I,NLXYK)+F(I,NLXYK+1))*S6(I,1)*(S5(I,1)-F(I,NVK))-     SETTEI.499
     2         (F(I,NLYXK)+F(I,NLYXK+1))*S5(I,1)*(S6(I,1)-F(I,NUK))+      SETTEI.500
     3         (F(I,NLYYK)+F(I,NLYYK+1))*S5(I,1)*(S5(I,1)-F(I,NVK)))      SETTEI.501
C      ****                                                               SETTEI.502
C      ****    SET TI                                                     SETTEI.503
C      ****                                                               SETTEI.504
       F(I,NTIK)=(S7(I,1)*S15(I,1)+S10(I,1)*F(I,NTEK)+S9(I,1)*            SETTEI.505
     1             F(I,NTK))/(S10(I,1)+S9(I,1))                           SETTEI.506
      ENDDO                                                               SETTEI.507
      RETURN                                                              SETTEI.508
      END                                                                 SETTEI.509
C                                                                         SETTEI.510
*DK SSFLUX                                                                SSFLUX.1
      SUBROUTINE SSFLUX(ISCALE,F107,F107A,FLYA,SFLUX)                     SSFLUX.2
      IMPLICIT REAL*8 (A-H,O-Z)                                           SSFLUX.3
      PARAMETER (LM=59)                                                   SSFLUX.4
      DIMENSION WAVE1(LM), WAVE2(LM), SFLUX(LM),                          SSFLUX.5
     +          WAVEL(LM), WAVES(LM), RFLUX(LM), XFLUX(LM),               SSFLUX.6
     +          SCALE1(LM), SCALE2(LM), SRA(8), SRB(8), B1(3), B2(3),     SSFLUX.7
     +          CHINT(LM),CHSLP(LM),COINT(LM),COSLP(LM),W1(LM),W2(LM),    SSFLUX.8
     +          WCHR(LM),FLUXCH(LM),FLUXCO(LM),WAVEAV(59)                 SSFLUX.9
      DATA B1/1.0, 0.0138, 0.005/, B2/1.0, 0.59425, 0.3811/               SSFLUX.10
      DATA WAVEL/ 1750.00, 1700.00, 1650.00, 1600.00, 1550.00, 1500.00,   SSFLUX.11
     +            1450.00, 1400.00, 1350.00, 1300.00, 1250.00, 1215.67,   SSFLUX.12
     +            1200.00, 1150.00, 1100.00, 1050.00, 1031.91, 1025.72,   SSFLUX.13
     +            1000.00,  977.02,  950.00,  900.00,  850.00,  800.00,   SSFLUX.14
     +             789.36,  770.41,  765.15,  750.00,  703.31,  700.00,   SSFLUX.15
     +             650.00,  629.73,  609.76,  600.00,  584.33,  554.37,   SSFLUX.16
     +             550.00,  500.00,  465.22,  450.00,  400.00,  368.07,   SSFLUX.17
     +             350.00,  303.78,  303.31,  300.00,  284.15,  256.30,   SSFLUX.18
     +             250.00,  200.00,  150.00,  100.00,   50.00,   32.00,   SSFLUX.19
     +              23.00,   16.00,    8.00,    4.00,    2.00/            SSFLUX.20
      DATA WAVES/ 1700.00, 1650.00, 1600.00, 1550.00, 1500.00, 1450.00,   SSFLUX.21
     +            1400.00, 1350.00, 1300.00, 1250.00, 1200.00, 1215.67,   SSFLUX.22
     +            1150.00, 1100.00, 1050.00, 1000.00, 1031.91, 1025.72,   SSFLUX.23
     +             950.00,  977.02,  900.00,  850.00,  800.00,  750.00,   SSFLUX.24
     +             789.36,  770.41,  765.15,  700.00,  703.31,  650.00,   SSFLUX.25
     +             600.00,  629.73,  609.76,  550.00,  584.33,  554.37,   SSFLUX.26
     +             500.00,  450.00,  465.22,  400.00,  350.00,  368.07,   SSFLUX.27
     +             300.00,  303.78,  303.31,  250.00,  284.15,  256.30,   SSFLUX.28
     +             200.00,  150.00,  100.00,   50.00,   32.00,   23.00,   SSFLUX.29
     +              16.00,    8.00,    4.00,    2.00,    1.00/            SSFLUX.30
      DATA RFLUX/  370.45,  203.69,   96.00,   69.71,   50.70,   26.67,   SSFLUX.31
     +              17.21,    8.26,   12.86,    4.10,    5.20,  333.80,   SSFLUX.32
     +               2.78,    0.70,    3.07,    3.64,    3.18,    4.38,   SSFLUX.33
     +               1.78,    5.96,    4.22,    4.43,    1.93,    0.87,   SSFLUX.34
     +               0.79,    0.24,    0.20,    0.17,    0.39,    0.22,   SSFLUX.35
     +               0.17,    1.50,    0.45,    0.48,    1.58,    0.80,   SSFLUX.36
     +               0.51,    0.31,    0.18,    0.39,    0.21,    0.74,   SSFLUX.37
     +               0.87,    6.00,    0.24,    0.84,    0.10,    0.27,   SSFLUX.38
     +               0.92,    1.84,    0.13,    0.38,  0.0215,  0.0067,   SSFLUX.39
     +             0.0009,  0.0003,   1.D-6,   3.D-9,   1.D-11/           SSFLUX.40
      DATA XFLUX/  464.20,  241.50,  131.50,  101.90,   81.32,   48.71,   SSFLUX.41
     +              37.16,   21.14,   30.70,   11.20,   12.00,  438.80,   SSFLUX.42
     +               6.50,    1.60,    6.40,    8.66,    9.04,   13.12,   SSFLUX.43
     +               4.42,   13.18,   12.03,   13.29,    5.01,    2.18,   SSFLUX.44
     +               1.59,    0.67,    0.43,    0.43,    0.72,    0.46,   SSFLUX.45
     +               0.48,    3.02,    1.46,    1.02,    4.86,    1.59,   SSFLUX.46
     +               1.57,    1.67,    0.36,    0.99,    2.20,    1.39,   SSFLUX.47
     +               5.63,   11.28,    2.50,    4.14,    3.16,    0.59,   SSFLUX.48
     +               3.70,    4.85,    0.34,    1.15,    0.18,    0.08,   SSFLUX.49
     +              0.025,    0.03,   1.D-3,   3.D-5,   1.D-6/            SSFLUX.50
      DATA SCALE1/35347.5, 33095.6, 18040.6, 13733.0, 12564.2, 7121.38,   SSFLUX.51
     +            6608.74, 5779.89, 8009.80, 3186.34, 3033.78,  47555.,   SSFLUX.52
     +            1692.09,  405.95, 1516.20, 2731.70, 3314.57, 4375.00,   SSFLUX.53
     +            1316.91, 3621.91, 3908.56, 4432.54, 1541.21,  531.73,   SSFLUX.54
     +             364.83,    0.00,  116.00,  129.41,  162.48,   94.07,   SSFLUX.55
     +              41.29,  709.50,    0.00,  268.47, 1561.05,  367.64,   SSFLUX.56
     +             290.06,  184.36,    0.00,   86.15,    7.50,    0.00,   SSFLUX.57
     +               0.00, 2220.00,    0.00,   61.00,    0.00,   86.95,   SSFLUX.58
     +             206.00,  135.89,   60.35,  157.12,    7.06,    0.75,   SSFLUX.59
     +               0.00,    0.00,    0.00,    0.00,    0.00/            SSFLUX.60
      DATA SCALE2/   0.00,    0.00,    0.00,    0.00,    0.00,    0.00,   SSFLUX.61
     +               0.00,    0.00,    0.00,    0.00,    0.00,    0.00,   SSFLUX.62
     +               0.00,    0.00,    0.00,    0.00,    0.00,    0.00,   SSFLUX.63
     +               0.00,    0.00,    0.00,    0.00,    0.00,    0.00,   SSFLUX.64
     +               0.00,    5.34,    0.00,    0.00,    0.00,    0.54,   SSFLUX.65
     +               3.30,    0.00,   12.60,    0.00,    0.00,    0.00,   SSFLUX.66
     +               5.34,   11.63,    2.28,    5.56,   24.93,    8.16,   SSFLUX.67
     +              60.69,    0.00,   28.20,   45.90,   40.80,    1.27,   SSFLUX.68
     +              35.47,   42.80,    1.12,    6.19,    1.26,    0.69,   SSFLUX.69
     +               0.23,    0.30,    0.01,   3.D-4,   1.D-5/            SSFLUX.70
      DATA SRA/     0.536,   0.216,   0.203,   0.184,   0.175,   0.126,   SSFLUX.71
     +              0.114,   0.073/                                       SSFLUX.72
      DATA SRB/     334.0,   189.0,    82.2,    57.2,    38.8,    18.1,   SSFLUX.73
     +               9.46,    3.30/                                       SSFLUX.74
      DATA CHINT/0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.75
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.76
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.77
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.18223D-01,      SSFLUX.78
     +          -0.14763D-02, 0.13765D-02, 0.10044D-01, 0.48687D-01,      SSFLUX.79
     +           0.79848D-02, 0.16334D-02, 0.99890D-02, 0.12362D-01,      SSFLUX.80	
     +           0.38317D-02, 0.00000D+00, 0.22214D-02, 0.87883D-03,      SSFLUX.81
     +           0.65437D-02, 0.20197D-02, 0.11897D-02, 0.25303D-01,      SSFLUX.82
     +           0.00000D+00, 0.69859D-02, 0.15090D-02, 0.15679D-01,      SSFLUX.83
     +           0.71813D-02, 0.18873D-02, 0.00000D+00, 0.44750D-02,      SSFLUX.84
     +           0.43206D-03, 0.00000D+00, 0.00000D+00, 0.24958D+00,      SSFLUX.85
     +           0.00000D+00, 0.17434D-03, 0.00000D+00, 0.11585D-01,      SSFLUX.86
     +           0.11532D-01, 0.98362D-02, 0.24461D-02, 0.91696D-02,      SSFLUX.87
     +           0.86457D-03, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.88
     +           0.00000D+00, 0.00000D+00, 0.00000D+00/                   SSFLUX.89
      DATA CHSLP/0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.90
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.91
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.92
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.13097D-01,      SSFLUX.93
     +           0.15670D-01, 0.20808D-01, 0.66142D-02, 0.18084D-01,      SSFLUX.94
     +           0.20603D-01, 0.24699D-01, 0.91077D-02, 0.49109D-02,      SSFLUX.95
     +           0.79057D-03, 0.00000D+00, 0.73979D-03, 0.83584D-03,      SSFLUX.96
     +           0.11269D-02, 0.68429D-03, 0.34588D-03, 0.54965D-02,      SSFLUX.97
     +           0.00000D+00, 0.23091D-02, 0.13033D-01, 0.32354D-02,      SSFLUX.98
     +           0.27878D-02, 0.17867D-02, 0.00000D+00, 0.10032D-02,      SSFLUX.99
     +           0.96861D-04, 0.00000D+00, 0.00000D+00, 0.35650D-01,      SSFLUX.100
     +           0.00000D+00, 0.96698D-03, 0.00000D+00, 0.16549D-02,      SSFLUX.101
     +           0.44742D-02, 0.38025D-02, 0.23655D-02, 0.10185D-01,      SSFLUX.102
     +           0.96072D-03, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.103
     +           0.00000D+00, 0.00000D+00, 0.00000D+00/                   SSFLUX.104
      DATA COINT/0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.105
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.106
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.107
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.108
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.109
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.74083D-03,      SSFLUX.110
     +           0.00000D+00, 0.13995D-02, 0.00000D+00, 0.00000D+00,      SSFLUX.111
     +           0.00000D+00, 0.13215D-02,-0.52657D-03, 0.00000D+00,      SSFLUX.112
     +           0.17231D-03, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.113
     +          -0.57828D-02,-0.14201D-01, 0.44921D-02, 0.81510D-03,      SSFLUX.114
     +          -0.38050D-01, 0.25868D-01,-0.74031D-01, 0.00000D+00,      SSFLUX.115
     +          -0.49781D-01,-0.65154D-01,-0.93662D-01, 0.00000D+00,      SSFLUX.116
     +          -0.59300D-01, 0.12726D-01, 0.32644D-02,-0.64290D-02,      SSFLUX.117
     +          -0.17720D-01,-0.17972D-01, 0.00000D+00, 0.00000D+00,      SSFLUX.118
     +           0.00000D+00, 0.00000D+00, 0.00000D+00/                   SSFLUX.119
      DATA COSLP/0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.120
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.121
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.122
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.123
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.124
     +           0.00000D+00, 0.00000D+00, 0.00000D+00, 0.35613D-04,      SSFLUX.125
     +           0.00000D+00, 0.67265D-04, 0.00000D+00, 0.00000D+00,      SSFLUX.126
     +           0.00000D+00, 0.71233D-05, 0.45645D-04, 0.00000D+00,      SSFLUX.127
     +           0.20078D-03, 0.00000D+00, 0.00000D+00, 0.00000D+00,      SSFLUX.128
     +           0.98801D-04, 0.23753D-03, 0.45868D-04, 0.12901D-03,      SSFLUX.129
     +           0.64519D-03, 0.20540D-03, 0.17408D-02, 0.00000D+00,      SSFLUX.130
     +           0.90311D-03, 0.17093D-02, 0.13948D-02, 0.00000D+00,      SSFLUX.131
     +           0.15455D-02, 0.23847D-02, 0.87499D-04, 0.79916D-03,      SSFLUX.132
     +           0.34005D-03, 0.31881D-03, 0.00000D+00, 0.00000D+00,      SSFLUX.133
     +           0.00000D+00, 0.00000D+00, 0.00000D+00/                   SSFLUX.134
      DATA W1/   0.00000, 0.00000, 0.00000, 0.00000, 0.00000, 0.00000,    SSFLUX.135
     +           0.00000, 0.00000, 0.00000, 0.00000, 0.00000, 0.00000,    SSFLUX.136
     +           0.00000, 0.00000, 0.00000, 0.50000, 0.50000, 0.50000,    SSFLUX.137
     +           0.50000, 0.50000, 0.50000, 0.50000, 0.50000, 0.00000,    SSFLUX.138
     +           0.50000, 0.00000, 0.50000, 0.50000, 0.50000, 0.90000,    SSFLUX.139
     +           4.50000, 0.50000, 0.00000, 0.50000, 0.50000, 0.50000,    SSFLUX.140
     +           0.55000, 0.40000, 0.00000, 0.07000, 0.02000, 0.00000,    SSFLUX.141
     +           0.00000, 1.00000, 0.00000, 0.18000, 0.00000, 1.00000,    SSFLUX.142
     +           0.33750, 1.12500, 1.12500, 0.80000, 0.24000, 0.00000,    SSFLUX.143
     +           0.00000, 0.00000, 0.00000, 0.00000, 0.00000/             SSFLUX.144
      DATA W2/   0.00000, 0.00000, 0.00000, 0.00000, 0.00000, 0.00000,    SSFLUX.145
     +           0.00000, 0.00000, 0.00000, 0.00000, 0.00000, 0.00000,    SSFLUX.146
     +           0.00000, 0.00000, 0.00000, 0.22750, 0.22750, 0.22750,    SSFLUX.147
     +           0.22750, 0.22750, 0.22750, 0.22750, 0.22750, 0.00000,    SSFLUX.148
     +           0.22750, 1.50000, 0.22750, 0.22750, 0.22750, 0.30000,    SSFLUX.149
     +           3.00000, 0.22750, 0.80000, 0.22750, 0.22750, 0.22750,    SSFLUX.150
     +           0.25000, 0.90000, 1.30000, 0.13000, 1.18000, 0.50000,    SSFLUX.151
     +           0.80000, 0.22750, 2.00000, 2.07000, 1.05000, 0.22750,    SSFLUX.152
     +           1.91250, 1.12500, 1.12500, 1.20000, 1.76000, 2.00000,    SSFLUX.153
     +           0.00000, 0.00000, 0.00000, 0.00000, 0.00000/             SSFLUX.154
      DATA WCHR/ 0.00000, 0.00000, 0.00000, 0.00000, 0.00000, 0.00000,    SSFLUX.155
     +           0.00000, 0.00000, 0.00000, 0.00000, 0.00000, 0.00000,    SSFLUX.156
     +           0.00000, 0.00000, 0.00000, 1.00000, 1.00000, 1.10000,    SSFLUX.157
     +           2.00000, 0.30000, 1.50000, 1.80000, 2.00000, 0.00000,    SSFLUX.158
     +           8.00000, 1.00000, 3.50000, 1.30000, 0.10000, 1.00000,    SSFLUX.159
     +           1.00000, 0.10000, 1.00000, 2.50000, 0.30000, 0.10000,    SSFLUX.160
     +           1.00000, 1.00000, 1.00000, 1.00000, 1.00000, 1.00000,    SSFLUX.161
     +           1.00000, 0.10000, 1.00000, 1.00000, 1.00000, 1.00000,    SSFLUX.162
     +           1.00000, 1.00000, 1.00000, 1.00000, 1.00000, 1.00000,    SSFLUX.163
     +           0.00000, 0.00000, 0.00000, 0.00000, 0.00000/             SSFLUX.164
      DATA WAVEAV/  0.000,    0.000,    0.000,    0.000,                  SSFLUX.165
     +              0.000,    0.000,    0.000,    0.000,                  SSFLUX.166
     +              0.000,    0.000,    0.000,    0.000,                  SSFLUX.167
     +              0.000,    0.000,    0.000, 1025.500,                  SSFLUX.168
     +           1031.900, 1025.700,  975.500,  977.020,                  SSFLUX.169
     +            925.500,  875.500,  825.500,  775.005,                  SSFLUX.170
     +            787.710,  770.410,  765.150,  725.500,                  SSFLUX.171
     +            703.360,  675.150,  626.930,  629.730,                  SSFLUX.172
     +            609.760,  576.985,  584.330,  554.370,                  SSFLUX.173
     +            525.000,  476.185,  465.220,  418.920,                  SSFLUX.174
     +            377.915,  368.070,  326.580,  303.780,                  SSFLUX.175
     +            303.310,  275.300,  284.150,  256.320,                  SSFLUX.176
     +            224.600,  174.340,  124.470,   75.255,                  SSFLUX.177
     +             39.620,   24.070,    0.000,    0.000,                  SSFLUX.178
     +              0.000,    0.000,    0.000/                            SSFLUX.179
C     ****                                                                SSFLUX.180
C     ****     HINTEREGGER METHOD                                         SSFLUX.181
C     ****                                                                SSFLUX.182
      IF(ISCALE.EQ.0)THEN                                                 SSFLUX.183
       R1=B1(1)+B1(2)*(F107A-71.5)+B1(3)*(F107-F107A+3.9)                 SSFLUX.184
       R2=B2(1)+B2(2)*(F107A-71.5)+B2(3)*(F107-F107A+3.9)                 SSFLUX.185
       DO L=1,LM                                                          SSFLUX.186
        IF(L.LT.9)THEN                                                    SSFLUX.187
         SFLUX(L)=SRA(L)*F107+SRB(L)                                      SSFLUX.188
        ELSE                                                              SSFLUX.189
         IF(L.EQ.12)THEN                                                  SSFLUX.190
          SFLUX(L)=332.+0.6*(F107-65.)                                    SSFLUX.191
         ELSE                                                             SSFLUX.192
          SFLUX(L)=(RFLUX(L)+((R1-1)*SCALE1(L)                            SSFLUX.193
     +             +(R2-1)*SCALE2(L))/1000.)                              SSFLUX.194
          IF(SFLUX(L).LT.0.0)SFLUX(L)=0.0                                 SSFLUX.195
         ENDIF                                                            SSFLUX.196
        ENDIF                                                             SSFLUX.197
       ENDDO                                                              SSFLUX.198
      ELSE                                                                SSFLUX.199
C      ****                                                               SSFLUX.200
C      ****     LINEAR INTERPOLATION METHOD                               SSFLUX.201
C      ****                                                               SSFLUX.202
       FRAT=(F107-68.)/(243.-68.)                                         SSFLUX.203
       DO L=1,LM                                                          SSFLUX.204
        SFLUX(L)=RFLUX(L)+(XFLUX(L)-RFLUX(L))*FRAT                        SSFLUX.205
       ENDDO                                                              SSFLUX.206
      ENDIF                                                               SSFLUX.207
C     ****                                                                SSFLUX.209
C     ****     TOBISKA AND BARTH METHOD                                   SSFLUX.210
C     ****                                                                SSFLUX.211
      F107MD=0                                                            SSFLUX.212
      IF(ISCALE.EQ.2)THEN                                                 SSFLUX.213
       IF(FLYA.LT.1)THEN                                                  SSFLUX.214
        FLYA=(F107+218.88)/1.05453D-9                                     SSFLUX.215
        F107MD=F107                                                       SSFLUX.216
       ELSE                                                               SSFLUX.217
        F107MD=(1.05453D-9*FLYA)-218.88                                   SSFLUX.218
       ENDIF                                                              SSFLUX.219
       FLYA=FLYA*((12400*1.602D-12)/(1215.67)) !TO ERGS                   SSFLUX.220
       DO J=16,54                                                         SSFLUX.221
        FLUXCH(J)=CHINT(J)+(CHSLP(J)*WCHR(J)*FLYA)                        SSFLUX.222
        FLUXCO(J)=COINT(J)+COSLP(J)*((W1(J)*F107MD)+(W2(J)*F107))         SSFLUX.223
        SFLUX(J)=FLUXCH(J)+FLUXCO(J)                                      SSFLUX.224
        SFLUX(J)=SFLUX(J)*((WAVEAV(J))/(12400*1.602D-12)) !TO PHOTONS     SSFLUX.225
        SFLUX(J)=SFLUX(J)*1.D-9 !TO COMPENSATE FOR *1.D9 THAT FOLLOWS     SSFLUX.226
       ENDDO                                                              SSFLUX.227
       FLYA=FLYA*((1215.67)/(12400.*1.602D-12))   !BACK TO PHOTONS        SSFLUX.228
      ENDIF                                                               SSFLUX.229
      SFNORM=2.-(F107-68.)/(243.-68.)                                     SSFLUX.230
      IF(SFNORM.LT.1.0)SFNORM=1.0                                         SSFLUX.231
      DO L=1,LM                                                           SSFLUX.232
       WAVE1(L)=WAVEL(L)                                                  SSFLUX.233
       WAVE2(L)=WAVES(L)                                                  SSFLUX.234
       IF(WAVE1(L).LT.251..AND.WAVE2(L).GT.0.1)                           SSFLUX.235
     +    SFLUX(L)=SFLUX(L)*SFNORM                                        SSFLUX.236
       SFLUX(L)=SFLUX(L)*1.D9                                             SSFLUX.237
      ENDDO                                                               SSFLUX.238
      RETURN                                                              SSFLUX.239
      END                                                                 SSFLUX.240
C                                                                         SSFLUX.241
*DK SUN                                                                      SUN.1
      SUBROUTINE SUN                                                         SUN.2
      INCLUDE 'param.h'                                                      SUN.3
      INCLUDE 'const.h'                                                      SUN.4
      INCLUDE 'start.h'                                                      SUN.5
      COMMON/TRGM/RLATM(ZIMXP,ZJMX),RLONM(ZIMXP,ZJMX),                       SUN.6
     1DIPMAG(ZIMXP,ZJMX),DECMAG(ZIMXP,ZJMX),SNDEC(ZIMXP,ZJMX),               SUN.7
     2CSDEC(ZIMXP,ZJMX),SN2DEC(ZIMXP,ZJMX),SNCSDC(ZIMXP,ZJMX)                SUN.8
     3,RLATMP(ZJMX),RLONMP(ZJMX),DLONS(ZJMX)                                 SUN.9
C     ****                                                                   SUN.10
C     ****     CALCULATE SUN'S LONGITUDE, DLONS, IN DIPOLE COORDINATES.      SUN.11
C     ****     UT IS UNIVERSAL TIME IN SECONDS.                              SUN.12
C     ****     IIDAY IS DAY OF YEAR                                          SUN.13
C     ****                                                                   SUN.14
C     ****     CALCULATE SUN'S GEOGRAPHIC COORDINATES.                       SUN.17
C     ****                                                                   SUN.18
      GLATS=DASIN(.398749*DSIN(2.*C(110)*DBLE(IIDAY-80)/365.))               SUN.19
      GLONS=C(110)*(1.-2.*SECS/86400.)                                       SUN.20
C     ****                                                                   SUN.21
C     ****     CALCULATE SUN'S APEX LONGITUDE USING BILINEAR                 SUN.22
C     ****       INTERPOLATION                                               SUN.23
C     ****                                                                   SUN.24
C     ****     FILL ARRAY DLONS(ZJMX) WITH THIS VALUE                        SUN.25
C     ****                                                                   SUN.26
      PISUN=(GLONS+C(110))/C(1)+1                                            SUN.27
      PJSUN=(GLATS+.5*(C(110)-C(2)))/C(2)+1.                                 SUN.28
      ISUN=PISUN                                                             SUN.29
      JSUN=PJSUN                                                             SUN.30
      PISUN=PISUN-DBLE(ISUN)                                                 SUN.31
      PJSUN=PJSUN-DBLE(JSUN)                                                 SUN.32
      SNDLONS=(1.-PISUN)*(1.-PJSUN)*DSIN(RLONM(ISUN+2,JSUN))+                SUN.33
     1         PISUN*(1.-PJSUN)*DSIN(RLONM(ISUN+3,JSUN))+                    SUN.34
     2         PISUN*PJSUN*DSIN(RLONM(ISUN+3,JSUN+1))+                       SUN.35
     3         (1.-PISUN)*PJSUN*DSIN(RLONM(ISUN+2,JSUN+1))                   SUN.36
      CSDLONS=(1.-PISUN)*(1-PJSUN)*DCOS(RLONM(ISUN+2,JSUN))+                 SUN.37
     1         PISUN*(1.-PJSUN)*DCOS(RLONM(ISUN+3,JSUN))+                    SUN.38
     2         PISUN*PJSUN*DCOS(RLONM(ISUN+3,JSUN+1))+                       SUN.39
     3         (1.-PISUN)*PJSUN*DCOS(RLONM(ISUN+2,JSUN+1))                   SUN.40
      DLONS(1)=DATAN2(SNDLONS,CSDLONS)                                       SUN.41
      DO J=2,JMAX                                                            SUN.42
       DLONS(J)=DLONS(1)                                                     SUN.43
      ENDDO                                                                  SUN.44
      RETURN                                                                 SUN.45
      END                                                                    SUN.46
C                                                                            SUN.47
*DK SWDOT                                                                  SWDOT.1
      SUBROUTINE SWDOT                                                     SWDOT.2
C     ****                                                                 SWDOT.3
C     ****     CALCULATES W ON LINE NJ AND Z TO NJNP                       SWDOT.4
C     ****                                                                 SWDOT.5
      INCLUDE 'param.h'                                                    SWDOT.6
      INCLUDE 'vscrw.h'                                                    SWDOT.7
      INCLUDE 'const.h'                                                    SWDOT.8
      INCLUDE 'index.h'                                                    SWDOT.9
      INCLUDE 'buffe.h'                                                    SWDOT.10
      INCLUDE 'phycs.h'                                                    SWDOT.11
C     ****                                                                 SWDOT.12
C     ****     S1=DIVRG(V)                                                 SWDOT.13
C     ****                                                                 SWDOT.14
      CALL DIVRG(S1)                                                       SWDOT.15
C     ****                                                                 SWDOT.16
C     ****      INSERT PERIODIC POINTS  FOR W                              SWDOT.17
C     ****                                                                 SWDOT.18
      DO I=1,2                                                             SWDOT.19
       DO K=1,KMAX                                                         SWDOT.20
        S1(I,K)=S1(I+IMAX,K)                                               SWDOT.21
        S1(I+IMAXP2,K)=S1(I+2,K)                                           SWDOT.22
       ENDDO                                                               SWDOT.23
      ENDDO                                                                SWDOT.24
C     ****                                                                 SWDOT.25
C     ****     W(KMAXP1)=S1(KMAX)                                          SWDOT.26
C     ****                                                                 SWDOT.27
      NWK=NJNP+NW                                                          SWDOT.28
      DO I=1,LEN1                                                          SWDOT.29
       F(I,NWK+KMAX)=S1(I,KMAX)                                            SWDOT.30
      ENDDO                                                                SWDOT.31
C     ****                                                                 SWDOT.32
C     ****     W(K)=C(86)*(C(86)*W(K+1)+C(3)*S1(K))                        SWDOT.33
C     ****                                                                 SWDOT.34
      NWK=NWK+KMAX                                                         SWDOT.35
      DO KK=1,KMAX                                                         SWDOT.36
       K=KMAXP1-KK                                                         SWDOT.37
       NWK=NWK-1                                                           SWDOT.38
       DO I=1,LEN1                                                         SWDOT.39
        F(I,NWK)=C(86)*(C(86)*F(I,NWK+1)+C(3)*S1(I,K))                     SWDOT.40
       ENDDO                                                               SWDOT.41
      ENDDO                                                                SWDOT.42
      NZNPK=NJNP+NZ                                                        SWDOT.43
      NZK=NJ+NZ                                                            SWDOT.44
      DO I=1,LEN3                                                          SWDOT.45
       F(I,NZNPK)=F(I,NZK)                                                 SWDOT.46
      ENDDO                                                                SWDOT.47
      NWK=NJNP+NW                                                          SWDOT.48
      CALL FILTER(NWK,KMAXP1,KUT(J))                                       SWDOT.49
      NWK=NJNP+NW-1                                                        SWDOT.50
      DO K=1,KMAX                                                          SWDOT.51
       NWK=NWK+1                                                           SWDOT.52
       DO I=1,2                                                            SWDOT.53
        F(I,NWK)=F(I+IMAX,NWK)                                             SWDOT.54
        F(I+IMAXP2,NWK)=F(I+2,NWK)                                         SWDOT.55
       ENDDO                                                               SWDOT.56
      ENDDO                                                                SWDOT.57
      RETURN                                                               SWDOT.58
      END                                                                  SWDOT.59
C                                                                          SWDOT.60
*DK TAIL                                                                    TAIL.1
      SUBROUTINE TAIL (SECS)                                                TAIL.2
      INCLUDE 'param.h'                                                     TAIL.3
      INCLUDE 'const.h'                                                     TAIL.4
C     ****                                                                  TAIL.5
C     ****     ROUTINE TO CALCULATE AURORAL CONSTANTS AS FUNCTION OF        TAIL.6
C     ****     TIME FOR THE NORMAL CASE USING THE REVISED ALFA (10/86)      TAIL.7
C     ****     AND THE NEW POLAR CAP CONVECTION (5/87)                      TAIL.8
C     ****     SECS=UNIVERSAL TIME IN SECONDS WHERE                         TAIL.9
C     ****          0.12 (MDAY.IHR) = 0.0  (UTMDAY.UTHR)                    TAIL.10
C     ****          1.0  (MDAY.IHR) = 0.12 (UTMDAY.UTHR)                    TAIL.11
C     ****          1.12 (MDAY.IHR) = 1.0  (UTMDAY.UTHR)                    TAIL.12
C     ****                                                                  TAIL.13
      PARAMETER (NAURPX=5,NLEX=600)                                         TAIL.14
      COMMON/AURDAT0/AURPS(NLEX,2,NAURPX),PARAMV(NAURPX)                    TAIL.15
      COMMON/AURDAT1/NAURP,NPTS(NAURPX)                                     TAIL.16
      COMMON/INSOL/ F107,F107A                                              TAIL.17
C     ****                                                                  TAIL.18
C     ****     AURORAL PARAMETERS IN DEGREES ETC.                           TAIL.19
C     ****                                                                  TAIL.20
      COMMON /PARAMD/ THETA0(2),OFFA(2),OFFC(2),DSKOFA(2),DSKOFC(2),        TAIL.21
     1 PHID(2),PHIN(2),PHIDP0(2),PHIDM0(2),PHINP0(2),PHINM0(2),             TAIL.22
     2 PSIM(2),PSIE(2),PCEN(2)                                              TAIL.23
     |, ARAD(2),H1,H2,ROTH,E1,E2,ROTE,EC,ED,ALFA1,ALFA2,TWAK,TWA6,TWA21,    TAIL.24
     | ROT6,ROT21,D6,D21,H6,H21,T6,T21                                      TAIL.25
C     ****                                                                  TAIL.26
C     ****     AURORAL PARAMETERS IN RADIANS ETC FOR FLOWV3                 TAIL.27
C     ****                                                                  TAIL.28
      COMMON /IONCR/ISTAR,IHEM,RDEG(22),PSIV(6),R1(2),
     1              COLATC(IMAXMP,JMX0),P(IMX0,JMX0),CRIT(2)                TAIL.29
      COMMON /OVALR/ RRAD(2),H0,RH,RROTH,E0,REE,RROTE,FC,ALFAC,FD,ALFAD     TAIL.30
     |, ALFK,ALF6,ALF21,RROT6,RROT21,RD6,RD6V,RD21,RH6,RH21,RT6,RT21        TAIL.31
     |, ALFA0,RALFA,ALFA20,RALFA2,E20,RE2                                   TAIL.32
      DATA CONVRT/3.1211D8/,DTR/1.7453293D-2/,E/1.D-10/,IFRST/0/            TAIL.33
      COMMON /RADII/ RHP,RCP,RAURSH,RAURNH,HPGWSH,HPGWNH                    TAIL.34
      COMMON/C6/C61,C62           
C     ****                                                                  TAIL.35
C     ****     UNIVERSAL TIME IN HOURS                                      TAIL.36
C     ****                                                                  TAIL.37
      UT=SECS/3600.                                                         TAIL.38
C     ****                                                                  TAIL.39
C     ****     INTERPOLATE NAURP PARAMETERS                                 TAIL.40
C     ****                                                                  TAIL.41
      I=1                                                                   TAIL.42
      F107=TERP(AURPS(1,1,I),AURPS(1,2,I),UT,NPTS(I))                       TAIL.43
      IF(NPTS(I).GT.1)THEN                                                  TAIL.44
       IF(UT .LT. AURPS(1,1,I) .OR. UT .GT. AURPS(NPTS(I),1,I)) THEN        TAIL.45
        WRITE(6,"(1X,'TAIL: STOP---UT OUT OF BOUNDS, UT UTMIN UTMAX =',     TAIL.46
     |  3F7.2,'  F107')") UT,AURPS(1,1,I),AURPS(NPTS(I),1,I)                TAIL.47
        STOP                                                                TAIL.48
       ENDIF                                                                TAIL.49
      ENDIF                                                                 TAIL.50
      I=2                                                                   TAIL.51
      F107A=TERP( AURPS(1,1,I),AURPS(1,2,I),UT,NPTS(I))                     TAIL.52
      IF(NPTS(I).GT.1)THEN                                                  TAIL.53
       IF (UT .LT. AURPS(1,1,I) .OR. UT .GT. AURPS(NPTS(I),1,I)) THEN       TAIL.54
        WRITE(6,"(1X,'TAIL: STOP---UT OUT OF BOUNDS, UT UTMIN UTMAX =',     TAIL.55
     |  3F7.2,'  F107A')") UT,AURPS(1,1,I),AURPS(NPTS(I),1,I)               TAIL.56
        STOP                                                                TAIL.57
       ENDIF                                                                TAIL.58
      ENDIF                                                                 TAIL.59
      DO I=3,NAURP                                                          TAIL.60
       IF(NPTS(I).EQ.1)GO TO 101                                            TAIL.61
       IF(UT.LT.AURPS(1,1,I).OR.UT.GT.AURPS(NPTS(I),1,I))THEN               TAIL.62
        WRITE(6,"(1X,'TAIL:  STOP---UT OUT OF BOUNDS, UT UTMIN UTMAX =',    TAIL.63
     |  3F7.2)") UT,AURPS(1,1,I),AURPS(NPTS(I),1,I)                         TAIL.64
        STOP                                                                TAIL.65
       ENDIF                                                                TAIL.66
101    PARAMV(I)=TERP(AURPS(1,1,I),AURPS(1,2,I),UT,NPTS(I))                 TAIL.67
      ENDDO                                                                 TAIL.68
      PLEVEL=0.                                                             TAIL.69
      HP=PARAMV(3)                                                          TAIL.70
      CP=PARAMV(4)                                                          TAIL.71
      BYIMF=PARAMV(5)                                                       TAIL.72
      IF(HP.GE.0.01)PLEVEL=2.09*DLOG(HP)                                    TAIL.73
C     ****                                                                  TAIL.74
C     **** PUT F107,F107A INTO CONSTANT ARRAY                               TAIL.75
C     ****                                                                  TAIL.76
      C(61)=F107                                                            TAIL.77
      C(62)=F107A                                                           TAIL.78
      C61=C(61)
      C62=C(62)
C     ****                                                                  TAIL.79
C     ****     FIND LIMITS OF BY WHICH ARE VALID FOR MODEL OF (3/89)        TAIL.80
      BYGD=DMIN1(7.D0,BYIMF)                                                  TAIL.81
      BYGD=DMAX1(-11.D0,BYGD)                                                 TAIL.82
      IHP=1                                                                 TAIL.83
      IHN=2                                                                 TAIL.84
      IF(BYIMF.GT.0.)THEN                                                   TAIL.85
       IHP=2                                                                TAIL.86
       IHN=1                                                                TAIL.87
      ENDIF                                                                 TAIL.88
C     ****                                                                  TAIL.89
C     ****     ASSUME THAT WE ARE ALWAYS DEALING WITH S AND N HEM IN PARAMV TAIL.90
C     ****                                                                  TAIL.91
      INH=2                                                                 TAIL.92
      ISH=1                                                                 TAIL.93
      HP35=DMIN1(HP,35.D0)                                                    TAIL.94
      HPM35=DMAX1(0.D0,HP-35.D0)                                                TAIL.95
C     ****                                                                  TAIL.96
C     ****     SET CUSP AND DRIZZLE PARAMETERS                              TAIL.97
C     ****                                                                  TAIL.98
C     ****     CHANGE CUSP AND DRIZZLE PARAMETERS                           TAIL.99
C     ****     (IN TGCM3 HAD EC=0.40, ALFAC=0.09, ED=0.05, ALFAD=0.20)      TAIL.100
C     ****     (WAS TOO MUCH ED ESPECIALLY.)                                TAIL.101
C     ****                                                                  TAIL.102
       EC = 0.1+0.9*HP/100.     ! cray version                              TAIL.103
       EC=EC/10             ! cray version
c      EC=(0.24+0.0067*HP)/5   ! wb version
      ALFAC=0.5                                                             TAIL.114
       ED = 0.1+2.*HP/100.      ! cray version                              TAIL.115
       ED=ED/10             ! cray version
c      ED=0.0012+0.0006*HP  ! wb version
       ALFAD=0.750         ! cray version
c      ALFAD=0.50       ! wb version                                       TAIL.116
      FC=CONVRT*EC/ALFAC                                                    TAIL.117
      FD=CONVRT*ED/ALFAD                                                    TAIL.118
C     ****                                                                  TAIL.119
C     ****     SECOND ALFA REPRESENTING LOW ENERGIES AT HIGH ALTITUDES      TAIL.120
C     ****                                                                  TAIL.121
      E21=1.D-80
      E22=1.D-80
      ALFA21=0.075                                                          TAIL.124
      ALFA22=0.075                                                          TAIL.125
      ALFA20=0.5*(ALFA21+ALFA22)                                            TAIL.126
      RALFA2=(ALFA22-ALFA21)/(ALFA21+ALFA22+E)                              TAIL.127
C     ****                                                                  TAIL.211
C     ****     MADE NEW MODEL IN 3/89                                       TAIL.212
C     ****     ION CONVECTION PARAMETERS:                                   TAIL.213
C     *****                                                                 TAIL.214
      DSKOFC(INH)=-0.08-0.15*BYGD                                           TAIL.215
      DSKOFC(ISH)=-0.08+0.15*BYGD                                           TAIL.216
      PHID(INH)=(9.39-0.21*BYGD-12.)*15.                                    TAIL.217
      PHID(ISH)=(9.39+0.21*BYGD-12.)*15.                                    TAIL.218
      PHIN(INH)=(23.50-0.15*BYGD-12.)*15.                                   TAIL.219
      PHIN(ISH)=(23.50+0.15*BYGD-12.)*15.                                   TAIL.220
      PCEN(INH)=(-0.168-0.027*BYGD)*CP                                      TAIL.221
      PCEN(ISH)=(-0.168+0.027*BYGD)*CP                                      TAIL.222
      DO IH=1,2                                                             TAIL.223
       R1(IH)=-2.6                                                          TAIL.224
       THETA0(IH)=-3.80+8.48*(CP**0.1875)                                   TAIL.225
       OFFC(IH)=1.1                                                         TAIL.226
       PSIM(IH)=0.44*CP                                                     TAIL.227
       PSIE(IH)=-0.56*CP                                                    TAIL.228
       PHIDP0(IH)=85.                                                       TAIL.229
       PHIDM0(IH)=50.                                                       TAIL.230
       PHINP0(IH)=57.5                                                      TAIL.231
       PHINM0(IH)=100.                                                      TAIL.232
C      ****                                                                 TAIL.233
C      ****     AURORAL PRECIPITATION                                       TAIL.234
C      ****                                                                 TAIL.235
       RHP=14.20+0.96*PLEVEL                                                TAIL.236
C      ****                                                                 TAIL.237
C      ****     FORMULA FOR IMF POTENTIALS                                  TAIL.238
C      ****                                                                 TAIL.239
       RCP=-0.43+9.69*(CP**0.1875)                                          TAIL.240
       ARAD(IH)=DMAX1(RHP,RCP)                                              TAIL.241
      ENDDO                                                                 TAIL.242
      OFFA(INH)=3.7                                                         TAIL.243
      OFFA(ISH)=4.3                                                         TAIL.244
      DSKOFA(INH)=-1.26-0.15*BYGD                                           TAIL.245
      DSKOFA(ISH)=-1.26+0.15*BYGD                                           TAIL.246
      DISP=ARAD(1)-THETA0(1)                                                TAIL.247
      DISPC=DSKOFC(1)-DSKOFA(1)                                             TAIL.248
      E1=DMAX1(0.5D0,-2.15+0.62*PLEVEL)                                      TAIL.250
      E2=0.95+0.117*HP                                                      TAIL.251
      ROTE=(2.62-0.55*PLEVEL)*15.                                           TAIL.252
      H1=DMIN1(2.35D0,0.83+0.33*PLEVEL)                                       TAIL.253
      H2=2.87+0.15*PLEVEL                                                   TAIL.254
      ROTH=(12.18D0-0.89*PLEVEL)*15.                                          TAIL.255
C     ****                                                                  TAIL.256
C     ****     AURORAL PRECIPITATION                                        TAIL.257
C     ****                                                                  TAIL.258
 135  RHP=14.20+0.96*PLEVEL                                                 TAIL.259
C     ****                                                                  TAIL.260
C     ****     FORMULA FOR IMF POTENTIALS                                   TAIL.261
C     ****                                                                  TAIL.262
      RCP=-0.43+9.69*(CP**0.1875)                                           TAIL.263
      RAUR=DMAX1(RCP,RHP)                                                   TAIL.264
C     ****                                                                  TAIL.265
C     ****     ELECTRON MEAN ENERGIES                                       TAIL.266
C     ****                                                                  TAIL.267
      TWAK=0.50                                                             TAIL.268
      TWA6=0.36+0.48*PLEVEL                                                 TAIL.270
      TWA21=DMAX1(1.D0,-1.75+0.69*PLEVEL)                                   TAIL.271
      ROT6=(6.-12.)*15.                                                     TAIL.273
      ROT21=(21.-12.)*15.                                                   TAIL.274
      T6=7.00                                                               TAIL.275
      T21=4.00                                                              TAIL.276
      D6=-4.0                                                               TAIL.277
      D6V=0.                                                                TAIL.278
      D21=4.0                                                               TAIL.279
      H6=7.0                                                                TAIL.280
      H21=10.0                                                              TAIL.281
      IF(HP.LT.0.01)THEN                                                    TAIL.282
       E1=1.D-20                                                            TAIL.283
       E2=1.D-20                                                            TAIL.284
       EC=1.D-20                                                            TAIL.285
       ED=1.D-20                                                            TAIL.286
       E21=1.D-20                                                           TAIL.287
       E22=1.D-20                                                           TAIL.288
      ENDIF                                                                 TAIL.289
      RAURSH=ARAD(1)                                                        TAIL.290
      RAURNH=ARAD(2)                                                        TAIL.291
C     ****                                                                  TAIL.292
C     ****     SET SHIELDING RADIUS FOR FOSSIL WIND                         TAIL.293
C     ****                                                                  TAIL.294
      THETSH=ARAD(2)+H2                                                     TAIL.295
C     ****                                                                  TAIL.314
C     ****     SET INITIALIZATION FLAG                                      TAIL.315
C     ****                                                                  TAIL.316
      ISTAR=0                                                               TAIL.317
C     ****                                                                  TAIL.318
C     ****    INSERT VALUES IN COMMON BLOCK, PARAMS.                        TAIL.319
C     ****                                                                  TAIL.320
      RRAD(1)=ARAD(1)*DTR                                                   TAIL.321
      RRAD(2)=ARAD(2)*DTR                                                   TAIL.322
      RROTH=ROTH*DTR                                                        TAIL.323
      RROTE=ROTE*DTR                                                        TAIL.324
      H0=0.5*(H1+H2)*DTR                                                    TAIL.325
      RH=(H2-H1)/(H1+H2+E)                                                  TAIL.326
      E0=0.5*(E1+E2)                                                        TAIL.327
      REE=(E2-E1)/(E2+E1)                                                   TAIL.328
      E20=0.5*(E21+E22)                                                     TAIL.329
      RE2=(E22-E21)/(E21+E22)                                               TAIL.330
C     ****                                                                  TAIL.331
C     ****     CALCULATE HEMISPHERIC POWER                                  TAIL.332
C     ****                                                                  TAIL.333
      PI=3.1415926535898                                                    TAIL.334
      P0=E0*(2.*PI**1.5)*((6.37D8+1.D7)**2)*((ARAD(1)                       TAIL.335
     1   *PI)/180.)*H0                                                      TAIL.336
      HPGWSH=P0*(1.+0.5*REE*RH*DCOS(RROTH-RROTE))/1.D+16                    TAIL.337
      HPGWNH=HPGWSH*ARAD(2)/ARAD(1)                                         TAIL.338
      DO N=1,22                                                             TAIL.339
       RDEG(N)=THETA0(N)*DTR                                                TAIL.340
      ENDDO                                                                 TAIL.341
      DO N=1,6                                                              TAIL.342
       PSIV(N)=PSIM(N)*1000.                                                TAIL.343
      ENDDO                                                                 TAIL.344
C     ****                                                                  TAIL.345
C     ****     ADD IN VARIATIONS TO 2*ALFA   (SEP 1986)                     TAIL.346
C     ****                                                                  TAIL.347
      ALFK=TWAK*0.5                                                         TAIL.348
      ALF6=TWA6*0.5                                                         TAIL.349
      ALF21=TWA21*0.5                                                       TAIL.350
      RROT6=ROT6*DTR                                                        TAIL.351
      RROT21=ROT21*DTR                                                      TAIL.352
      RD6=D6*DTR                                                            TAIL.353
      RD6V=D6V*DTR                                                          TAIL.354
      RD21=D21*DTR                                                          TAIL.355
      RH6=H6*DTR                                                            TAIL.356
      RH21=H21*DTR                                                          TAIL.357
      RT6=T6*15.*DTR                                                        TAIL.358
      RT21=T21*15.*DTR                                                      TAIL.359
      RETURN                                                                TAIL.360
      END                                                                   TAIL.361
C                                                                           TAIL.362
*DK TERP                                                                    TERP.1
      FUNCTION TERP(X,Y,XI,N)                                               TERP.2
      IMPLICIT REAL*8 (A-H,O-Z)                                             TERP.3
C     ****                                                                  TERP.4
C     ****     PERFORMS LINEAR INTERPOLATION IN TABLE OF N (X,Y) POINTS     TERP.5
C     ****     X(N) IS ARRAY OF MONOTONICALLY INCREASING ABSCISSAE          TERP.6
C     ****     Y(N) IS ARRAY OF CORRESPONDING ORDINATES                     TERP.7
C     ****     XI IS ABSCISSA AT WHICH INTERPOLATION IS REQUIRED            TERP.8
C     ****     N IS NUMBER OF POINTS IN TABLE                               TERP.9
C     ****     INTERPOLATED VALUE IS RETURNED IN TERP                       TERP.10
C     ****                                                                  TERP.11
C     ****                                                                  TERP.12
      DIMENSION X(1),Y(1)                                                   TERP.13
C     ****                                                                  TERP.14
C     ****     SEARCH FOR INTERVAL IN WHICH XI FALLS                        TERP.15
C     ****                                                                  TERP.16
      IF(N.EQ.1)THEN                                                        TERP.17
       TERP=Y(1)                                                            TERP.18
      ELSE                                                                  TERP.19
       NN=1                                                                 TERP.20
       DO I=1,N-1                                                           TERP.21
        IF(XI.GT.X(I))NN=I                                                  TERP.22
       ENDDO                                                                TERP.23
C      ****                                                                 TERP.24
C      ****     PERFORM LINEAR INTERPOLATION                                TERP.25
C      ****                                                                 TERP.26
       TERP=((X(NN+1)-XI)*Y(NN)+(XI-X(NN))*Y(NN+1))/(X(NN+1)-X(NN))         TERP.27
      ENDIF                                                                 TERP.28
      RETURN                                                                TERP.29
      END                                                                   TERP.30
C                                                                           TERP.31
*DK TRSOLV                                                                TRSOLV.1
      SUBROUTINE TRSOLV(A,B,C,F,W,X,IF,I1,I2,KF,K1,K2,NF)                 TRSOLV.2
C     ****     SOLVES TRIDIAGONAL SYSTEM                                  TRSOLV.3
C     ****     A(I,K)*X(I,K-1)+B(I,K)*X(I,K)+C(I,K)*X(I,K+1)=F(I,K)       TRSOLV.4
C     ****     WHERE I=I1,I2,1 AND K=K1,K2,1 AND A(I,K1)=C(I,K2)=0.       TRSOLV.5
C     ****     ARRAYS A,B,C,F,W,X ARE DIMENSIONED (IF,KF)                 TRSOLV.6
C     ****     WHERE 1.LE.I1.LT.I2.LE.IF AND 1.LE.K1.LT.K2.LE.KF          TRSOLV.7
C     ****     W IS WORK SPACE                                            TRSOLV.8
C     ****     THE ROUTINE USES VECTOR OPERATIONS ON ARRAYS OF LENGTH     TRSOLV.9
C     ****     IMAX=I2-I1+1                                               TRSOLV.10
      IMPLICIT REAL*8 (A-H,O-Z)                                           TRSOLV.11
      DIMENSION A(IF,KF),B(IF,KF),C(IF,KF),F(IF,KF),W(IF,KF),X(IF,KF)     TRSOLV.12
      DIMENSION BETA(76,29),GAMA(76,29)                                   TRSOLV.13
C     ****                                                                TRSOLV.14
C     ****     684 AND 25 ARE TWO NUMBERS TO DEFINE THE LOCAL ARRAYS      TRSOLV.15
C     ****     BETA AND GAMA. THEY ARE DESIGNED FOR TWO LEVEL OF          TRSOLV.16
C     ****     NESTING WITH 1:3 RATIOS (76*9) AND 25 PRESSURE LEVELS.     TRSOLV.17
C     ****     YOU SHOULD REDIFINE THOSE TWO ARRAYS IF YOUR PROGRAMM      TRSOLV.18
C     ****     EXCEEDS THOSE LIMITS                                       TRSOLV.19
C     ****                                                                TRSOLV.20
      IMAX=I2-I1+1                                                        TRSOLV.21
      K1P=K1+1                                                            TRSOLV.22
      IMAX=IMAX+2                                                         TRSOLV.23
      DO I=I1,IMAX                                                        TRSOLV.24
       BETA(I,K1)=B(I,K1)                                                 TRSOLV.25
       DO K=K1P,K2                                                        TRSOLV.26
        GAMA(I,K)=C(I,K-1)/BETA(I,K-1)                                    TRSOLV.27
        BETA(I,K)=B(I,K)-A(I,K)*GAMA(I,K)                                 TRSOLV.28
       ENDDO                                                              TRSOLV.29
       W(I,K1)=F(I,K1)/BETA(I,K1)                                         TRSOLV.30
       DO K=K1P,K2                                                        TRSOLV.31
        W(I,K)=(F(I,K)-A(I,K)*W(I,K-1))/BETA(I,K)                         TRSOLV.32
       ENDDO                                                              TRSOLV.33
       X(I,K2)=W(I,K2)                                                    TRSOLV.34
       DO K=K2-1,K1,-1                                                    TRSOLV.35
        X(I,K)=W(I,K)-X(I,K+1)*GAMA(I,K+1)                                TRSOLV.36
       ENDDO                                                              TRSOLV.37
      ENDDO                                                               TRSOLV.38
      RETURN                                                              TRSOLV.39
      END                                                                 TRSOLV.40
C                                                                         TRSOLV.41
*DK VQUART                                                                VQUART.1
      SUBROUTINE VQUART(A,ROOT,W1,W2,W3,LEN,I1,I2)                        VQUART.2
      IMPLICIT REAL*8 (A-H,O-Z)                                           VQUART.3
C     ****                                                                VQUART.4
C     ****     VECTOR PROCEDURE DETERMINES +IVE ROOTS OF EQUATIONS        VQUART.5
C     ****     A(I,5)*X**4+4.*A(I,4)*X**3+6.*A(I,3)*X**2+4.*A(I,2)*X      VQUART.6
C     ****     +A(I,1)=0., WHERE I=1,LEN                                  VQUART.7
C     ****                                                                VQUART.8
C     ****     PROCEDURE IS SPECIFICALLY DESIGNED FOR REAL QUARTICS WITH  VQUART.9
C     ****     REAL ROOTS ONLY ONE OF WHICH IS POSITIVE                   VQUART.10
C     ****                                                                VQUART.11
      DIMENSION A(LEN,5),ROOT(LEN),W1(LEN),W2(LEN),W3(LEN)                VQUART.12
C     ****                                                                VQUART.13
C     ****     COEFFICIENTS OF QUARTICS TRANSMITTED IN ARRAY A(LEN,5)     VQUART.14
C     ****     POSITIVE ROOTS RETURNED IN ROOT(LEN)                       VQUART.15
C     ****     W1(LEN),W2(LEN),W3(LEN) ARE WORKING ARRAYS                 VQUART.16
C     ****     LEN IS FIRST DIMENSION OF A                                VQUART.17
C     ****     I1,I2 GIVE RANGE OVER WHICH QUARTICS ARE TO BE SOLVED      VQUART.18
C     ****                                                                VQUART.19
      DATA E/1.D-256/                                                     VQUART.20
      DO I=I1,I2                                                          VQUART.21
C      ****                                                               VQUART.22
C      ****     W1=CH                                                     VQUART.23
C      ****                                                               VQUART.24
       W1(I)=-(A(I,5)*A(I,1)-4*A(I,4)*A(I,2)+3*A(I,3)**2)/12.             VQUART.25
C      ****                                                               VQUART.26
C      ****     W2=CG                                                     VQUART.27
C      ****                                                               VQUART.28
       W2(I)=(A(I,5)*(A(I,3)*A(I,1)-A(I,2)**2)-A(I,4)*(A(I,4)*A(I,1)-     VQUART.29
     1       A(I,2)*A(I,3))+A(I,3)*(A(I,4)*A(I,2)-A(I,3)**2))/4.          VQUART.30
C      ****                                                               VQUART.31
C      ****     ROOT=RLAM=-2.*REAL((.5*(CMPLX(CG,0.)+CSQRT(CMPLX(CG**2+4. VQUART.32
C      ****     *CH**3+E,0.)))+CMPLX(E,0.))**(1./3.))                     VQUART.33
C      ****                                                               VQUART.34
       ROOT(I)=-2.*DREAL((.5*(DCMPLX(W2(I),0.)+CDSQRT(DCMPLX(W2(I)**2+    VQUART.35
     1         4.*W1(I)**3+E,0.)))+DCMPLX(E,0.))**(1./3.))                VQUART.36
C      ****                                                               VQUART.37
C      ****     W1=P=SQRT(A(5)*RLAM+A(4)**2-A(5)*A(3)+E)                  VQUART.38
C      ****                                                               VQUART.39
       W1(I)=A(I,5)*ROOT(I)+A(I,4)**2-A(I,5)*A(I,3)+E                     VQUART.40
       IF(W1(I).LT.0.)W1(I)=0.                                            VQUART.41
       W1(I)=DSQRT(W1(I))                                                 VQUART.42
C      ****                                                               VQUART.43
C      ****     W2=Q=SQRT((2.*RLAM+A(3))**2-A(5)*A(1)+E)                  VQUART.44
C      ****                                                               VQUART.45
       W2(I)=DSQRT((2.*ROOT(I)+A(I,3))**2-A(I,5)*A(I,1)+E)                VQUART.46
C      ****                                                               VQUART.47
C      ****     W3=PQ=2.*A(4)*RLAM+A(4)*A(3)-A(5)*A(2)+E                  VQUART.48
C      ****                                                               VQUART.49
       W3(I)=2.*A(I,4)*ROOT(I)+A(I,4)*A(I,3)-A(I,5)*A(I,2)+E              VQUART.50
C      ****                                                               VQUART.51
C      ****     W1=P=SIGN(P,Q*PQ)                                         VQUART.52
C      ****                                                               VQUART.53
       W1(I)=DSIGN(W1(I),W2(I)*W3(I))                                     VQUART.54
C      ****                                                               VQUART.55
C      ****     W3=P-A4                                                   VQUART.56
C      ****                                                               VQUART.57
       W3(I)=W1(I)-A(I,4)                                                 VQUART.58
C      ****                                                               VQUART.59
C      ****     FINAL EVALUATION OF REQUIRED ROOT                         VQUART.60
C      ****                                                               VQUART.61
       ROOT(I)=(W3(I)+DSQRT(W3(I)**2-A(I,5)*(A(I,3)+2.*ROOT(I)-W2(I))))   VQUART.62
     1         /A(I,5)                                                    VQUART.63
      ENDDO                                                               VQUART.64
      RETURN                                                              VQUART.65
      END                                                                 VQUART.66
C                                                                         VQUART.67
*DK XRAY                                                                    XRAY.1
      SUBROUTINE XRAY                                                       XRAY.2
C     ****                                                                  XRAY.3
C     ****     CALCULATES PRODUCTION OF IONS, N2N AND N4S BY SOLAR          XRAY.4
C     ****     X-RAYS                                                       XRAY.5
C     ****                                                                  XRAY.6
      INCLUDE 'param.h'                                                     XRAY.7
      INCLUDE 'vscrw.h'                                                     XRAY.8
      INCLUDE 'const.h'                                                     XRAY.9
      INCLUDE 'index.h'                                                     XRAY.10
      INCLUDE 'buffe.h'                                                     XRAY.11
      DATA SF/1.0/,EPSX/5.0/                                                XRAY.12
      EX=0.3+0.5*(C(61)-67.)/(176.*SF)                                      XRAY.13
C     ****                                                                  XRAY.14
C     ****     S1=PSI1(K),  S2=PSI2(K),  S3=T(K)                            XRAY.15
C     ****                                                                  XRAY.16
      NTK=NJ+NT                                                             XRAY.17
      NPS1K=NJ+NPS                                                          XRAY.18
      NPS2K=NJ+NPS2                                                         XRAY.19
      DO I=1,LEN2-LEN1                                                      XRAY.20
       S1(I,2)=.5*(F(I,NPS1K)+F(I,NPS1K+1))                                 XRAY.21
       S2(I,2)=.5*(F(I,NPS2K)+F(I,NPS2K+1))                                 XRAY.22
       S3(I,2)=.5*(F(I,NTK)+F(I,NTK+1))                                     XRAY.23
      ENDDO                                                                 XRAY.24
      DO I=1,LEN1                                                           XRAY.25
       S1(I,1)=1.5*F(I,NPS1K)-0.5*F(I,NPS1K+1)                              XRAY.26
       S2(I,1)=1.5*F(I,NPS2K)-0.5*F(I,NPS2K+1)                              XRAY.27
       S3(I,1)=1.5*F(I,NTK)-0.5*F(I,NTK+1)                                  XRAY.28
       S1(I,KMAXP1)=1.5*F(I,NPS1K+KMAXM1)-0.5*F(I,NPS1K+KMAX-2)             XRAY.29
       S2(I,KMAXP1)=1.5*F(I,NPS2K+KMAXM1)-0.5*F(I,NPS2K+KMAX-2)             XRAY.30
       S3(I,KMAXP1)=1.5*F(I,NTK+KMAXM1)-0.5*F(I,NTK+KMAX-2)                 XRAY.31
      ENDDO                                                                 XRAY.32
C     ****                                                                  XRAY.33
C     ****     S4=N*MBAR                                                    XRAY.34
C     ****                                                                  XRAY.35
      NMSK=NJ+NMS-1                                                         XRAY.36
      DO K=1,KMAX                                                           XRAY.37
       NMSK=NMSK+1                                                          XRAY.38
       DO I=1,LEN1                                                          XRAY.39
        S4(I,K)=C(81)*C(87)*EXPS(K)*F(I,NMSK)/(C(84)*S3(I,K))               XRAY.40
       ENDDO                                                                XRAY.41
      ENDDO                                                                 XRAY.42
      NMSK=NMSK+1                                                           XRAY.43
      DO I=1,LEN1                                                           XRAY.44
       S4(I,KMAXP1)=C(81)*C(86)*EXPS(KMAX)*F(I,NMSK)/                       XRAY.45
     1              (C(84)*S3(I,KMAXP1))                                    XRAY.46
      ENDDO                                                                 XRAY.47
C     ****                                                                  XRAY.48
C     ****     S1=N(O2),  S2=N(O),   S3=N(N2),  (K)                         XRAY.49
C     ****                                                                  XRAY.50
      DO I=1,LEN3                                                           XRAY.51
       S3(I,1)=(1.-S1(I,1)-S2(I,1))/RMASS(3)*S4(I,1)                        XRAY.52
       S1(I,1)=S1(I,1)/RMASS(1)*S4(I,1)                                     XRAY.53
       S2(I,1)=S2(I,1)/RMASS(2)*S4(I,1)                                     XRAY.54
      ENDDO                                                                 XRAY.55
C     ****                                                                  XRAY.56
C     ****     S4=T=2.52D9*EX*EPSX*EXP(-TAU)                                XRAY.57
C     ****     S1=PX(O2),   S2=PX(O),   S3=PX(N2)     (K)                   XRAY.58
C     ****                                                                  XRAY.59
      NNO2K=NNO2                                                            XRAY.60
      NNOK=NNO                                                              XRAY.61
      NNN2K=NNN2                                                            XRAY.62
      DO I=1,LEN3                                                           XRAY.63
       S4(I,1)=2.52D9*EX*EPSX*DEXP(-(4.4D-19*F(I,NNO2K)+2.0D-19*            XRAY.64
     &         F(I,NNOK)+2.35D-19*F(I,NNN2K)))                              XRAY.65
       S1(I,1)=4.4D-19*S1(I,1)*S4(I,1)                                      XRAY.66
       S2(I,1)=2.0D-19*S2(I,1)*S4(I,1)                                      XRAY.67
       S3(I,1)=2.35D-19*S3(I,1)*S4(I,1)                                     XRAY.68
      ENDDO                                                                 XRAY.69
C     ****                                                                  XRAY.70
C     ****     ADD IONIZATION CONTRIBUTIONS TO NQO2P, NQOP, NQN2P, NQNP     XRAY.71
C     ****                                                                  XRAY.72
      NQO2PK=NQO2P                                                          XRAY.73
      NQOPK=NQOP                                                            XRAY.74
      NQN2PK=NQN2P                                                          XRAY.75
      NQNPK=NQNP                                                            XRAY.76
      DO I=1,LEN3                                                           XRAY.77
       F(I,NQO2PK)=F(I,NQO2PK)+0.67*S1(I,1)                                 XRAY.78
       F(I,NQOPK)=F(I,NQOPK)+S2(I,1)+0.33*S1(I,1)                           XRAY.79
       F(I,NQN2PK)=F(I,NQN2PK)+0.64*S3(I,1)                                 XRAY.80
       F(I,NQNPK)=F(I,NQNPK)+0.36*S3(I,1)                                   XRAY.81
      ENDDO                                                                 XRAY.82
      RETURN                                                                XRAY.83
      END                                                                   XRAY.84
C                                                                           XRAY.85
