*DK N2MAIN                                                                  MAIN.1
      SUBROUTINE N2MAIN(LEVEL,MTER,ASTEP)                                   MAIN.2
      INCLUDE 'n2param.h'                                                   MAIN.3
      INCLUDE 'n2array.h'                                                   MAIN.4
      INCLUDE 'nestcnt.h'                                                   MAIN.5
      INCLUDE 'n2const.h'                                                   MAIN.6
      INCLUDE 'start.h'                                                     MAIN.7
      COMMON/N2INI/INITIAL,INIINPUT                                         MAIN.8
C     ****                                                                  MAIN.9
C     ****     INITIALIZATION OF THE NESTED GRID DOMAIN                     MAIN.10
C     ****                                                                  MAIN.11
      IF(INITIAL.EQ.0)THEN                                                  MAIN.12
C      ****                                                                 MAIN.13
C      ****     SPECIFY NESTED GRID PARAMETERS                              MAIN.14
C      ****                                                                 MAIN.15
       CALL N2CON(LEVEL,ASTEP)                                              MAIN.16
C      ****                                                                 MAIN.17
C      ****     SPECIFY MAGNETIC FIELDS                                     MAIN.18
C      ****                                                                 MAIN.19
       CALL N2MAGFIELD(LEVEL)                                               MAIN.20
       INITIAL=1                                                            MAIN.21
      ENDIF                                                                 MAIN.22
C     ****                                                                  MAIN.23
C     ****     INTERPOLATE COARSE GRID BOUNDARY VALUES TO THE NESTED        MAIN.24
C     ****     GRID DOMAIN                                                  MAIN.25
C     ****                                                                  MAIN.26
      CALL N2CSTOFN                                                         MAIN.27
      CALL N2IONDRIFT(LEVEL)                                                MAIN.28
C     ****                                                                  MAIN.29
C     ****     ADVANCE NESTED GRID SIMULATION BY ONE TIME STEP              MAIN.30
C     ****                                                                  MAIN.31
      CALL N2ADVNCE(MTER,LEVEL)                                             MAIN.32
      RETURN                                                                MAIN.33
      END                                                                   MAIN.34
C                                                                           MAIN.35
*DK ADDIAG                                                                ADDIAG.1
      SUBROUTINE N2ADDIAG(NTER)                                           ADDIAG.2
C     ****                                                                ADDIAG.3
C     ****     CALCULATES Z,M AND COS(PHI)*V ON LINE JP2                  ADDIAG.4
C     ****                                                                ADDIAG.5
      INCLUDE 'n2param.h'                                                 ADDIAG.6
      INCLUDE 'n2cvscr.h'                                                 ADDIAG.7
      INCLUDE 'n2array.h'                                                 ADDIAG.8
      INCLUDE 'buffe.h'                                                   ADDIAG.9
      INCLUDE 'n2const.h'                                                 ADDIAG.10
      INCLUDE 'index.h'                                                   ADDIAG.11
      INCLUDE 'start.h'                                                   ADDIAG.12
      INCLUDE 'n2phycs.h'                                                 ADDIAG.13
      COMPLEX*16 EXPT                                                     ADDIAG.14
C     ****                                                                ADDIAG.15
C     ****     NVC=COS(PHI)*V                                             ADDIAG.16
C     ****                                                                ADDIAG.17
      NVCK=NJP2+NVC                                                       ADDIAG.18
      NVK=NJP2+NV                                                         ADDIAG.19
      DO I=1,LEN2                                                         ADDIAG.20
       F(I,NVCK)=CS(J+2)*F(I,NVK)                                         ADDIAG.21
      ENDDO                                                               ADDIAG.22
C     ****                                                                ADDIAG.23
C     ****     CALCULATE MBAR                                             ADDIAG.24
C     ****                                                                ADDIAG.25
      NPS1K=NJP2+NPS                                                      ADDIAG.26
      NPS2K=NJP2+NPS2                                                     ADDIAG.27
      NMSK=NJP2+NMS                                                       ADDIAG.28
      DO I=1,LEN3                                                         ADDIAG.29
       F(I,NMSK)=1./(F(I,NPS1K)/RMASS(1)+F(I,NPS2K)/RMASS(2)+             ADDIAG.30
     A           (1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3))                     ADDIAG.31
      ENDDO                                                               ADDIAG.32
C     ****                                                                ADDIAG.33
C     ****     T1 = MBAR(K=0)  (LINEAR EXTRAPOLATION)                     ADDIAG.34
C     ****                                                                ADDIAG.35
      NMSK=NJP2+NMS                                                       ADDIAG.36
      DO I=1,LEN1                                                         ADDIAG.37
       T1(I)=1.5*F(I,NMSK)-0.5*F(I,NMSK+1)                                ADDIAG.38
      ENDDO                                                               ADDIAG.39
C     ****                                                                ADDIAG.40
C     ****     MBAR(K) = 0.5*(MBAR(K+1/2)+MBAR(K-1/2)),                   ADDIAG.41
C     ****       K = KMAXP1,2,1                                           ADDIAG.42
C     ****                                                                ADDIAG.43
      NMSK=NJP2+NMS+KMAXP1                                                ADDIAG.44
      DO K=1,KMAX                                                         ADDIAG.45
       NMSK=NMSK-1                                                        ADDIAG.46
       DO I=1,LEN1                                                        ADDIAG.47
        F(I,NMSK)=0.5*(F(I,NMSK)+F(I,NMSK-1))                             ADDIAG.48
       ENDDO                                                              ADDIAG.49
      ENDDO                                                               ADDIAG.50
C     ****                                                                ADDIAG.51
C     ****     MBAR(1) = T1                                               ADDIAG.52
C     ****                                                                ADDIAG.53
      NMSK=NJP2+NMS                                                       ADDIAG.54
      DO I=1,LEN1                                                         ADDIAG.55
       F(I,NMSK)=T1(I)                                                    ADDIAG.56
      ENDDO                                                               ADDIAG.57
C     ****                                                                ADDIAG.58
C     ****     CALCULATE Z                                                ADDIAG.59
C     ****                                                                ADDIAG.60
      NTK=NJP2+NT                                                         ADDIAG.61
      NMSK=NJP2+NMS                                                       ADDIAG.62
C     ****                                                                ADDIAG.63
C     ****     S1=T/M                                                     ADDIAG.64
C     ****                                                                ADDIAG.65
      C365=2.*C(3)/C(65)                                                  ADDIAG.66
      DO I=1,LEN2                                                         ADDIAG.67
       S1(I,1)=C365*F(I,NTK)/(F(I,NMSK)+F(I,NMSK+1))                      ADDIAG.68
      ENDDO                                                               ADDIAG.69
C     ****                                                                ADDIAG.70
C     ****     Z(1)=ZB                                                    ADDIAG.71
C     ****                                                                ADDIAG.72
      NZK=NJP2+NZ                                                         ADDIAG.73
      EXPT=CDEXP(CI*C(23)*C(4)*DBLE(NTER))                                ADDIAG.74
      DO I=1,LEN1                                                         ADDIAG.75
       F(I,NZK)=DREAL(ZB(J+2)*BND(I)*EXPT)                                ADDIAG.76
      ENDDO                                                               ADDIAG.77
C     ****                                                                ADDIAG.78
C     ****     ADD IN EFFECT OF (1,1) TIDAL COMPONENT                     ADDIAG.79
C     ****                                                                ADDIAG.80
      EXPT=CDEXP(CI*.5*C(23)*C(4)*DBLE(NTER))                             ADDIAG.81
      DO I=1,LEN1                                                         ADDIAG.82
       F(I,NZK)=F(I,NZK)+DREAL(ZB2(J+2)*BND2(I)*EXPT)                     ADDIAG.83
      ENDDO                                                               ADDIAG.84
C     ****                                                                ADDIAG.85
C     ****     ADD IN EFFECT OF ANNUAL TIDAL COMPONENT                    ADDIAG.86
C     ****                                                                ADDIAG.87
      EXPT=(1.,0.)                                                        ADDIAG.88
      DO I=1,LEN1                                                         ADDIAG.99
       F(I,NZK)=F(I,NZK)+DREAL(ZBA(J+2)*BNDA(I)*EXPT)                     ADDIAG.90
      ENDDO                                                               ADDIAG.91
C     ****                                                                ADDIAG.92
C     ****     Z(K+1)=S1(K)+Z(K)                                          ADDIAG.93
C     ****                                                                ADDIAG.94
      DO K=1,KMAX                                                         ADDIAG.95
       DO I=1,LEN1                                                        ADDIAG.96
        F(I,NZK+1)=S1(I,K)+F(I,NZK)                                       ADDIAG.97
       ENDDO                                                              ADDIAG.98
       NZK=NZK+1                                                          ADDIAG.99
      ENDDO                                                               ADDIAG.100
      RETURN                                                              ADDIAG.101
      END                                                                 ADDIAG.102
C                                                                         ADDIAG.103
*DK ADVEC                                                                  ADVEC.1
      SUBROUTINE N2ADVEC(NX,S)                                             ADVEC.2
C     ****                                                                 ADVEC.3
C     ****      Calculates fourth order advection                          ADVEC.4
C     ****                                                                 ADVEC.5
      include 'n2param.h'                                                  ADVEC.6
      include 'n2array.h'                                                  ADVEC.7
      include 'buffe.h'                                                    ADVEC.8
      include 'n2const.h'                                                  ADVEC.9
      include 'index.h'                                                    ADVEC.10
      include 'n2phycs.h'                                                  ADVEC.11
      DIMENSION S(IMX,KMXP),X(IMX,KMXP),Z(IMX,KMXP)                        ADVEC.12
C     ****                                                                 ADVEC.14
C     ****                   COMPUTE  X = RACS*DL(X)                       ADVEC.15
C     ****                                                                 ADVEC.16
C     ****                   UBARL = (U(I+1)+U(I-1))/2                     ADVEC.17
C     ****                   D2X = C(10)*(X(I+1)-X(I-1))*UBARL             ADVEC.18
C     ****                   UBARL = (U(I+2)+U(I-2))/2                     ADVEC.19
C     ****                   D4X = C(11)*(X(I+2)-X(I-2))*UBAR2L            ADVEC.20
C     ****                   X = (D2X-D4X)*RACS                            ADVEC.21
C     ****                                                                 ADVEC.22
      NXK=NJ+NX                                                            ADVEC.23
      NUK=NJ+NU                                                            ADVEC.24
      DO K=1,KMAX                                                          ADVEC.25
       DO I=3,LEN1-2                                                       ADVEC.26
        D2X=0.5*(F(I+1,NUK)+F(I-1,NUK))*(F(I+1,NXK)-F(I-1,NXK))*C(10)      ADVEC.27
        D4X=0.5*(F(I+2,NUK)+F(I-2,NUK))*(F(I+2,NXK)-F(I-2,NXK))*C(11)      ADVEC.30
        X(I,K)=(D2X-D4X)*RACS                                              ADVEC.31
       ENDDO                                                               ADVEC.32
       NXK=NXK+1                                                           ADVEC.33
       NUK=NUK+1                                                           ADVEC.34
      ENDDO                                                                ADVEC.35
C     ****                                                                 ADVEC.36
C     ****                   COMPUTE  C(52)*DP(X)                          ADVEC.37
C     ****                                                                 ADVEC.38
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,LEN1-2                                                       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     ****
C     ****                   D2X = (D2X-D4X)*C(52)                         ADVEC.76
C     ****                   S = X+D2X = ADVEC(X)                          ADVEC.77
      DO K=1,KMAX                                                          ADVEC.80
       DO I=3,LEN1-2                                                       ADVEC.81
        S(I,K)=X(I,K)+Z(I,K)                                               ADVEC.84
       ENDDO                                                               ADVEC.85
      ENDDO                                                                ADVEC.88
      RETURN                                                               ADVEC.89
      END                                                                  ADVEC.90
C                                                                          ADVEC.91
*DK ADVEC2                                                                ADVEC2.1
      SUBROUTINE N2ADVEC2(NX,S)                                           ADVEC2.2
C     ****                                                                ADVEC2.3
C     ****        Calculate points adjacent to the boundary for second    ADVEC2.4
C     ****        order advection                                         ADVEC2.5
C     ****                                                                ADVEC2.6
      include 'n2param.h'                                                 ADVEC2.7
      include 'n2array.h'                                                 ADVEC2.8
      include 'buffe.h'                                                   ADVEC2.9
      include 'n2const.h'                                                 ADVEC2.10
      include 'index.h'                                                   ADVEC2.11
      include 'n2phycs.h'                                                 ADVEC2.12
      DIMENSION S(IMX,KMXP),X(IMX,KMXP),UBARL(IMX,KMXP),VBARP(IMX,KMXP)   ADVEC2.13
     1,D2X(IMX,KMXP)                                                      ADVEC2.14
C     ****                                                                ADVEC2.15
C     ****                   COMPUTE  X = RACS*DL(X)                      ADVEC2.16
C     ****                                                                ADVEC2.17
C     ****                   lower boundary plus 1 (horizontally)         ADVEC2.18
C     ****                                                                ADVEC2.19
C     ****                   UBARL = (U(I+1)+U(I-1))/2                    ADVEC2.20
C     ****                                                                ADVEC2.21
      NUK=NJ+NU                                                           ADVEC2.22
      DO K=1,KMAX                                                         ADVEC2.23
        UBARL(2,K)=(F(3,NUK)+F(1,NUK))*.5                                 ADVEC2.24
        NUK=NUK+1                                                         ADVEC2.25
      ENDDO                                                               ADVEC2.26
C     ****                                                                ADVEC2.27
C     ****                   D2X = C(10)*(X(I+1)-X(I-1))                  ADVEC2.28
C     ****                   D2X = D2X*UBARL                              ADVEC2.29
C     ****                   X = (D2X)*RACS                               ADVEC2.30
C     ****                                                                ADVEC2.31
      NXK=NJ+NX                                                           ADVEC2.32
      DO K=1,KMAX                                                         ADVEC2.33
        D2X(2,K)=(F(3,NXK)-F(1,NXK))*C(10)*(3./4.)                        ADVEC2.34
        D2X(2,K)=D2X(2,K)*UBARL(2,K)                                      ADVEC2.35
        X(2,K)=D2X(2,K)*RACS                                              ADVEC2.36
        NXK=NXK+1                                                         ADVEC2.37
      ENDDO                                                               ADVEC2.38
C     ****                                                                ADVEC2.39
C     ****      upper boundary minus 1 (horizontally)                     ADVEC2.40
C     ****                                                                ADVEC2.41
C     ****                   UBARL = (U(I+1)+U(I-1))/2                    ADVEC2.42
C     ****                                                                ADVEC2.43
      LEN=LEN1-1                                                          ADVEC2.44
      NUK=NJ+NU                                                           ADVEC2.45
      DO K=1,KMAX                                                         ADVEC2.46
        UBARL(LEN,K)=(F(LEN+1,NUK)+F(LEN-1,NUK))*.5                       ADVEC2.47
        NUK=NUK+1                                                         ADVEC2.48
      ENDDO                                                               ADVEC2.49
C     ****                                                                ADVEC2.50
C     ****                   D2X = C(10)*(X(I+1)-X(I-1))                  ADVEC2.51
C     ****                   D2X = D2X*UBARL                              ADVEC2.52
C     ****                   X = (D2X)*RACS                               ADVEC2.53
C     ****                                                                ADVEC2.54
      NXK=NJ+NX                                                           ADVEC2.55
      DO K=1,KMAX                                                         ADVEC2.56
        D2X(LEN,K)=(F(LEN+1,NXK)-F(LEN-1,NXK))*C(10)*(3./4.)              ADVEC2.57
        D2X(LEN,K)=D2X(LEN,K)*UBARL(LEN,K)                                ADVEC2.58
        X(LEN,K)=D2X(LEN,K)*RACS                                          ADVEC2.59
        NXK=NXK+1                                                         ADVEC2.60
      ENDDO                                                               ADVEC2.61
C     ****                                                                ADVEC2.62
C     ****     lower boundary plus 1 (horizontally)                       ADVEC2.63
C     ****                                                                ADVEC2.64
C     ****                   COMPUTE  C(52)*DP(X)                         ADVEC2.65
C     ****                   VBARP = (V(J+1)+V(J-1))/2                    ADVEC2.66
C     ****                                                                ADVEC2.67
      NVJPK=NJP1+NV                                                       ADVEC2.68
      NVJMK=NJM1+NV                                                       ADVEC2.69
      DO K=1,KMAX                                                         ADVEC2.70
        VBARP(2,K)=(F(2,NVJPK)+F(2,NVJMK))*.5                             ADVEC2.71
        NVJPK=NVJPK+1                                                     ADVEC2.72
        NVJMK=NVJMK+1                                                     ADVEC2.73
      ENDDO                                                               ADVEC2.74
C     ****                                                                ADVEC2.75
C     ****                   D2X = C(12)*(X(J+1)-X(J-1))                  ADVEC2.76
C     ****                   D2X = D2X*VBARP                              ADVEC2.77
C     ****                   D2X = (D2X)*C(52)                            ADVEC2.78
C     ****                   S = X+D2X=ADVEC(X)                           ADVEC2.79
C     ****                                                                ADVEC2.80
      NXJPK=NJP1+NX                                                       ADVEC2.81
      NXJMK=NJM1+NX                                                       ADVEC2.82
      DO K=1,KMAX                                                         ADVEC2.83
        D2X(2,K)=(F(2,NXJPK)-F(2,NXJMK))*C(12)*(3./4.)                    ADVEC2.84
        D2X(2,K)=D2X(2,K)*VBARP(2,K)                                      ADVEC2.85
        D2X(2,K)=D2X(2,K)*C(52)                                           ADVEC2.86
        S(2,K)=X(2,K)+D2X(2,K)                                            ADVEC2.87
        NXJPK=NXJPK+1                                                     ADVEC2.88
        NXJMK=NXJMK+1                                                     ADVEC2.89
      ENDDO                                                               ADVEC2.90
C     ****                                                                ADVEC2.91
C     ****     Upper boundary minus 1 (horizontally)                      ADVEC2.92
C     ****                                                                ADVEC2.93
C     ****                  VBARP = (V(J+1)+V(J-1))/2                     ADVEC2.94
C     ****                                                                ADVEC2.95
      NVJPK=NJP1+NV                                                       ADVEC2.96
      NVJMK=NJM1+NV                                                       ADVEC2.97
      DO K=1,KMAX                                                         ADVEC2.98
        VBARP(LEN,K)=(F(LEN,NVJPK)+F(LEN,NVJMK))*.5                       ADVEC2.99
        NVJPK=NVJPK+1                                                     ADVEC2.100
        NVJMK=NVJMK+1                                                     ADVEC2.101
      ENDDO                                                               ADVEC2.102
C     ****                                                                ADVEC2.103
C     ****                   D2X = C(12)*(X(J+1)-X(J-1))                  ADVEC2.104
C     ****                   D2X = D2X*VBARP                              ADVEC2.105
C     ****                   D2X = (D2X)*RACS                             ADVEC2.106
C     ****                   S = X+D2X=ADVEC(X)                           ADVEC2.107
C     ****                                                                ADVEC2.108
      NXJPK=NJP1+NX                                                       ADVEC2.109
      NXJMK=NJM1+NX                                                       ADVEC2.110
      DO K=1,KMAX                                                         ADVEC2.111
        D2X(LEN,K)=(F(LEN,NXJPK)-F(LEN,NXJMK))*C(12)*3./4.                ADVEC2.112
        D2X(LEN,K)=D2X(LEN,K)*VBARP(LEN,K)                                ADVEC2.113
        D2X(LEN,K)=D2X(LEN,K)*C(52)                                       ADVEC2.114
        S(LEN,K)=X(LEN,K)+D2X(LEN,K)                                      ADVEC2.115
        NXJPK=NXJPK+1                                                     ADVEC2.116
        NXJMK=NXJMK+1                                                     ADVEC2.117
      ENDDO                                                               ADVEC2.118
      RETURN                                                              ADVEC2.119
      END                                                                 ADVEC2.120
C                                                                         ADVEC2.121
*DK ADVEC3                                                                ADVEC3.1
      SUBROUTINE N2ADVEC3(NX,S)                                           ADVEC3.2
C     ****                                                                ADVEC3.3
C     ****    Calculate points adjacent to the boundary for               ADVEC3.4
C     ****    second order advection                                      ADVEC3.5
C     ****                                                                ADVEC3.6
      include 'n2param.h'                                                 ADVEC3.7
      include 'n2array.h'                                                 ADVEC3.8
      include 'buffe.h'                                                   ADVEC3.9
      include 'n2const.h'                                                 ADVEC3.10
      include 'index.h'                                                   ADVEC3.11
      include 'n2phycs.h'                                                 ADVEC3.12
      DIMENSION S(IMX,KMXP),X(IMX,KMXP),UBARL(IMX,KMXP),VBARP(IMX,KMXP)   ADVEC3.13
     1,D2X(IMX,KMXP)                                                      ADVEC3.14
C     ****                                                                ADVEC3.15
C     ****    COMPUTE  X = RACS*DL(X)                                     ADVEC3.16
C     ****    UBARL = (U(I+1)+U(I-1))/2                                   ADVEC3.20
C     ****                                                                ADVEC3.21
      NUK=NJ+NU                                                           ADVEC3.22
      DO K=1,KMAX                                                         ADVEC3.23
        DO I=2,LEN1-1                                                     ADVEC3.24
          UBARL(I,K)=(F(I+1,NUK)+F(I-1,NUK))*.5                           ADVEC3.25
        ENDDO                                                             ADVEC3.26
        NUK=NUK+1                                                         ADVEC3.27
      ENDDO                                                               ADVEC3.28
C     ****                                                                ADVEC3.29
C     ****    D2X = C(10)*(X(I+1)-X(I-1))                                 ADVEC3.30
C     ****                                                                ADVEC3.31
C     ****    Adjust D2X for points one away from the boundary for        ADVEC3.32
C     ****    second order advection                                      ADVEC3.33
C     ****                                                                ADVEC3.34
      NXK=NJ+NX                                                           ADVEC3.35
      DO K=1,KMAX                                                         ADVEC3.36
        DO I=2,LEN1-1                                                     ADVEC3.37
          D2X(I,K)=(F(I+1,NXK)-F(I-1,NXK))*C(10)*(3./4.)                  ADVEC3.38
        ENDDO                                                             ADVEC3.39
C       ****                                                              ADVEC3.40
C       ****    X = D2X*UBARL*RACS                                        ADVEC3.41
C       ****                                                              ADVEC3.42
        DO I=2,LEN1-1                                                     ADVEC3.43
          X(I,K)=D2X(I,K)*UBARL(I,K)*RACS                                 ADVEC3.44
        ENDDO                                                             ADVEC3.45
        NXK=NXK+1                                                         ADVEC3.46
      ENDDO                                                               ADVEC3.47
C     ****                                                                ADVEC3.48
C     ****    COMPUTE  C(52)*DP(X)                                        ADVEC3.49
C     ****                                                                ADVEC3.50
C     ****    VBARP = (V(J+1)+V(J-1))/2                                   ADVEC3.51
C     ****                                                                ADVEC3.52
      NVJPK=NJP1+NV                                                       ADVEC3.53
      NVJMK=NJM1+NV                                                       ADVEC3.54
      DO K=1,KMAX                                                         ADVEC3.55
        DO I=2,LEN1-1                                                     ADVEC3.56
          VBARP(I,K)=(F(I,NVJPK)+F(I,NVJMK))*.5                           ADVEC3.57
        ENDDO                                                             ADVEC3.58
        NVJPK=NVJPK+1                                                     ADVEC3.59
        NVJMK=NVJMK+1                                                     ADVEC3.60
      ENDDO                                                               ADVEC3.61
C     ****                                                                ADVEC3.62
C     ****    D2X = C(12)*(X(J+1)-X(J-1))                                 ADVEC3.63
C     ****                                                                ADVEC3.64
      NXJPK=NJP1+NX                                                       ADVEC3.65
      NXJMK=NJM1+NX                                                       ADVEC3.66
      DO K=1,KMAX                                                         ADVEC3.67
C       ****                                                              ADVEC3.68
C       ****    Adjust D2X for points one away from the boundary for      ADVEC3.69
C       ****    second order advection                                    ADVEC3.70
C       ****                                                              ADVEC3.71
        DO I=2,LEN1-1                                                     ADVEC3.72
          D2X(I,K)=(F(I,NXJPK)-F(I,NXJMK))*C(12)*(3./4.)                  ADVEC3.73
        ENDDO                                                             ADVEC3.74
C       ****                                                              ADVEC3.75
C       ****    D2X = D2X*VBARP*C(52)                                     ADVEC3.76
C       ****                                                              ADVEC3.77
        DO I=2,LEN1-1                                                     ADVEC3.78
          D2X(I,K)=D2X(I,K)*VBARP(I,k)*C(52)                              ADVEC3.79
        ENDDO                                                             ADVEC3.80
C       ****                                                              ADVEC3.81
C       ****    S = X+D2X = ADVEC(X)                                      ADVEC3.82
C       ****                                                              ADVEC3.83
        DO I=2,LEN1-1                                                     ADVEC3.84
          S(I,K)=X(I,K)+D2X(I,K)                                          ADVEC3.85
        ENDDO                                                             ADVEC3.86
        NXJPK=NXJPK+1                                                     ADVEC3.87
        NXJMK=NXJMK+1                                                     ADVEC3.88
      ENDDO                                                               ADVEC3.89
      RETURN                                                              ADVEC3.90
      END                                                                 ADVEC3.91
C                                                                         ADVEC3.92
*DK ADVECL                                                                ADVECL.1
      SUBROUTINE N2ADVECL(NX,S,K)                                         ADVECL.2
C     ****                                                                ADVECL.3
C     ****      Advection for major species composition                   ADVECL.4
C     ****                                                                ADVECL.5
      include 'n2param.h'                                                 ADVECL.6
      include 'n2array.h'                                                 ADVECL.7
      include 'buffe.h'                                                   ADVECL.8
      include 'n2const.h'                                                 ADVECL.9
      include 'index.h'                                                   ADVECL.10
      include 'n2phycs.h'                                                 ADVECL.11
      DIMENSION S(IMAX)                                                   ADVECL.12
      NUK=NJ+NU+(K-1)                                                     ADVECL.13
      NXJP2K=NJP2+NX                                                      ADVECL.14
      NXJP1K=NJP1+NX                                                      ADVECL.15
      NXK=NJ+NX                                                           ADVECL.16
      NXJM1K=NJM1+NX                                                      ADVECL.17
      NXJM2K=NJM2+NX                                                      ADVECL.18
      NVK=NV+K-1                                                          ADVECL.19
      NVJP2K=NJP2+NVK                                                     ADVECL.20
      NVJP1K=NJP1+NVK                                                     ADVECL.21
      NVJM1K=NJM1+NVK                                                     ADVECL.22
      NVJM2K=NJM2+NVK                                                     ADVECL.23
      IF(J.GT.2.AND.J.LT.JMAXM1)THEN                                      ADVECL.24
       DO I=3,LEN1-2                                                      ADVECL.25
        S(I)=.5*RACS*(C(10)*(F(I+1,NXK)-F(I-1,NXK))*(F(I+1,NUK)+          ADVECL.26
     A       F(I-1,NUK))-C(11)*(F(I+2,NXK)-F(I-2,NXK))*(F(I+2,NUK)+       ADVECL.27
     B       F(I-2,NUK)))+.5*C(52)*(C(12)*(F(I,NXJP1K)-F(I,NXJM1K))*      ADVECL.28
     C       (F(I,NVJP1K)+F(I,NVJM1K))-C(13)*(F(I,NXJP2K)-F(I,NXJM2K)     ADVECL.29
     D       )*(F(I,NVJP2K)+F(I,NVJM2K)))                                 ADVECL.30
       ENDDO                                                              ADVECL.31
      ELSE                                                                ADVECL.32
       DO I=3,LEN1-2                                                      ADVECL.33
        S(I)=.5*RACS*(C(10)*(F(I+1,NXK)-F(I-1,NXK))*(F(I+1,NUK)+          ADVECL.34
     A       F(I-1,NUK))-C(11)*(F(I+2,NXK)-F(I-2,NXK))*(F(I+2,NUK)+       ADVECL.35
     B       F(I-2,NUK)))+.5*C(52)*(C(12)*(F(I,NXJP1K)-F(I,NXJM1K))*      ADVECL.36
     C       (F(I,NVJP1K)+F(I,NVJM1K)))*3./4.                             ADVECL.37
       ENDDO                                                              ADVECL.38
      ENDIF                                                               ADVECL.39
      RETURN                                                              ADVECL.40
      END                                                                 ADVECL.41
C                                                                         ADVECL.42
*DK ADVECL2                                                              ADVECL2.1
      SUBROUTINE N2ADVECL2(NX,S,K)                                       ADVECL2.2
C     ****                                                               ADVECL2.3
C     ****      Advection for major species composition                  ADVECL2.4
C     ****                                                               ADVECL2.5
      include 'n2param.h'                                                ADVECL2.6
      include 'n2array.h'                                                ADVECL2.7
      include 'buffe.h'                                                  ADVECL2.8
      include 'n2const.h'                                                ADVECL2.9
      include 'index.h'                                                  ADVECL2.10
      include 'n2phycs.h'                                                ADVECL2.11
      DIMENSION S(IMAX)                                                  ADVECL2.12
      NUK=NJ+NU+(K-1)                                                    ADVECL2.13
      NXJP1K=NJP1+NX                                                     ADVECL2.14
      NXK=NJ+NX                                                          ADVECL2.15
      NXJM1K=NJM1+NX                                                     ADVECL2.16
      NVK=NV+K-1                                                         ADVECL2.17
      NVJM1K=NJM1+NVK                                                    ADVECL2.18
      NVJP1K=NJP1+NVK                                                    ADVECL2.19
      S(2)=.5*RACS*(C(10)*3./4.*(F(3,NXK)-F(1,NXK))*(F(3,NUK)+           ADVECL2.20
     1 F(1,NUK)))+.5*C(52)*(C(12)*3./4.*(F(2,NXJP1K)-F(2,NXJM1K))*       ADVECL2.21
     2 (F(2,NVJP1K)+F(2,NVJM1K)))                                        ADVECL2.22
      S(IMAX-1)=.5*RACS*(C(10)*3./4.*(F(IMAX,NXK)-F(IMAX-2,NXK))*        ADVECL2.23
     1 (F(IMAX,NUK)+F(IMAX-2,NUK)))+.5*C(52)*(C(12)*3./4.*               ADVECL2.24
     2 (F(IMAX-1,NXJP1K)-F(IMAX-1,NXJM1K))*                              ADVECL2.25
     3 (F(IMAX-1,NVJP1K)+F(IMAX-1,NVJM1K)))                              ADVECL2.26
      RETURN                                                             ADVECL2.27
      END                                                                ADVECL2.28
C                                                                        ADVECL2.29
*DK ADVECV                                                                ADVECV.1
      SUBROUTINE N2ADVECV(NX,S,T)                                         ADVECV.2
      include 'n2param.h'                                                 ADVECV.3
      include 'n2array.h'                                                 ADVECV.4
      include 'n2cvscr.h'                                                 ADVECV.5
      include 'buffe.h'                                                   ADVECV.6
      include 'n2const.h'                                                 ADVECV.7
      include 'index.h'                                                   ADVECV.8
      include 'n2phycs.h'                                                 ADVECV.9
      DIMENSION S(IMX,KMXP),T(IMX)                                        ADVECV.10
      NWK=NJNP+NW                                                         ADVECV.12
      NXK=NJ+NX                                                           ADVECV.13
C     ****                                                                ADVECV.14
C     ****     S3(1)=(NX(1)-T)*W(1)*2.                                    ADVECV.15
C     ****                                                                ADVECV.16
      DO I=2,LEN1-1                                                       ADVECV.17
        S3(I,1)=(F(I,NXK)-T(I))*F(I,NWK)*2.                               ADVECV.18
      ENDDO                                                               ADVECV.19
      DSIG=.5*C(20)                                                       ADVECV.20
      DO I=1,LEN1                                                         ADVECV.21
        S3(I,KMAXP1)=0.                                                   ADVECV.22
      ENDDO                                                               ADVECV.23
C     ****                                                                ADVECV.24
C     ****     S3(K)=(X(K)-X(K-1))*W(K)                                   ADVECV.25
C     ****                                                                ADVECV.26
      DO K=1,KMAX-1                                                       ADVECV.27
        DO I=2,LEN1-1                                                     ADVECV.28
         S3(I,K+1)=(F(I,NXK+1)-F(I,NXK))*F(I,NWK+1)                       ADVECV.29
        ENDDO                                                             ADVECV.30
       NXK=NXK+1                                                          ADVECV.31
       NWK=NWK+1                                                          ADVECV.32
      ENDDO                                                               ADVECV.33
C     ****                                                                ADVECV.34
C     ****     S3(K)=(S3(K)+S3(K+1))*DSIG                                 ADVECV.35
C     ****                                                                ADVECV.36
      DO K=1,KMAX                                                         ADVECV.37
        DO I=2,LEN1-1                                                     ADVECV.38
         S3(I,K)=(S3(I,K)+S3(I,K+1))*DSIG                                 ADVECV.39
        ENDDO                                                             ADVECV.40
C       ****                                                              ADVECV.41
C       ****     S=S+S3                                                   ADVECV.42
C       ****                                                              ADVECV.43
        DO I=2,LEN1-1                                                     ADVECV.44
          S(I,K)=S(I,K)+S3(I,K)                                           ADVECV.45
        ENDDO                                                             ADVECV.46
      ENDDO                                                               ADVECV.47
      RETURN                                                              ADVECV.48
      END                                                                 ADVECV.49
C                                                                         ADVECV.50
*DK ADVNCE                                                                ADVNCE.1
      SUBROUTINE N2ADVNCE(MTER,LEVEL)                                     ADVNCE.2
C     ****                                                                ADVNCE.3
C     ****     ADVANCES THE MODEL IN TIME                                 ADVNCE.4
C     ****                                                                ADVNCE.5
      INCLUDE 'n2param.h'                                                 ADVNCE.6
      INCLUDE 'n2cvscr.h'                                                 ADVNCE.7
      INCLUDE 'buffe.h'                                                   ADVNCE.8
      INCLUDE 'n2array.h'                                                 ADVNCE.9
      INCLUDE 'n2const.h'                                                 ADVNCE.10
      INCLUDE 'index.h'                                                   ADVNCE.11
      INCLUDE 'start.h'                                                   ADVNCE.12
      INCLUDE 'n2phycs.h'                                                 ADVNCE.13
      INCLUDE 'nestcnt.h'                                                 ADVNCE.14
      WRITE(6,5)MTER                                                      ADVNCE.15
    5 FORMAT(1H0,17X,'ADVANCE ENTERED AT MTER ',I6)                       ADVNCE.16
C     ****                                                                ADVNCE.17
C     ****     INITIALIZE BUFFER INDICES                                  ADVNCE.18
C     ****                                                                ADVNCE.19
      MODULO=8                                                            ADVNCE.20
      CALL INIT                                                           ADVNCE.21
C     ****                                                                ADVNCE.22
C     ****     TIME LOOP                                                  ADVNCE.23
C     ****                                                                ADVNCE.24
      NTER=MTER*NESTRI(LEVEL)                                             ADVNCE.25
      NTIME=0                                                             ADVNCE.26
  100 CONTINUE                                                            ADVNCE.27
      NTIME=NTIME+1                                                       ADVNCE.28
      NTER=NTER+1                                                         ADVNCE.29
C     ****                                                                ADVNCE.30
C     ****     FIND UT TIME  (MODEL DAY = UT DAY, 11/89)                  ADVNCE.31
C     ****                                                                ADVNCE.32
      SECS=DBLE(NTER)*C(4)                                                ADVNCE.33
      CALL TAIL(SECS)                                                     ADVNCE.34
C     ****                                                                ADVNCE.35
C     ****     BEGIN SWEEP OF MESH FROM SOUTH TO NORTH                    ADVNCE.36
C     ****     BRING IN LINE 1                                            ADVNCE.37
C     ****                                                                ADVNCE.38
c      CALL N1VDRIFT                                                       ADVNCE.39
      CALL FLIP                                                           ADVNCE.40
      DO I=1,IMAX*(KMAXP1*NHIST+1)                                        ADVNCE.41
       F(I,NJIN)=G(I,1,1)                                                 ADVNCE.42
      ENDDO                                                               ADVNCE.43
C     ****     BRING IN LINES 2 AND 3                                     ADVNCE.45
C     ****     AND REARRANGE LINES 1 AND 2                                ADVNCE.46
C     ****     TO FORM LINES 0 AND -1                                     ADVNCE.47
C     ****                                                                ADVNCE.48
      DO JP2=1,2                                                          ADVNCE.49
       CALL FLIP                                                          ADVNCE.50
       DO I=1,IMAX*(KMAXP1*NHIST+1)                                       ADVNCE.51
        F(I,NJIN)=G(I,1,JP2+1)                                            ADVNCE.52
       ENDDO                                                              ADVNCE.53
C      ****                                                               ADVNCE.54
C      ****     ADD DIAGNOSTIC QUANTITIES ONTO LINE JP2                   ADVNCE.55
C      ****                                                               ADVNCE.56
       J=JP2-2                                                            ADVNCE.57
       CALL N2ADDIAG(NTER)                                                ADVNCE.58
      ENDDO                                                               ADVNCE.59
C     ****                                                                ADVNCE.60
C     ****     GENERAL LINE LOOP (LATITUDINAL VARIATION)                  ADVNCE.61
C     ****                                                                ADVNCE.62
      DO 3000 J=1,JMAX                                                    ADVNCE.63
      RACS=1./(C(51)*CS(J))                                               ADVNCE.64
      CALL FLIP                                                           ADVNCE.65
C     ****                                                                ADVNCE.66
C     ****     START IN NEXT LINE NORTH                                   ADVNCE.67
C     ****                                                                ADVNCE.68
      IF(J.LT.JMAXM2) THEN                                                ADVNCE.69
       DO I=1,IMAX*(KMAXP1*NHIST+1)                                       ADVNCE.70
        F(I,NJIN)=G(I,1,J+3)                                              ADVNCE.71
       ENDDO                                                              ADVNCE.72
      END IF                                                              ADVNCE.73
C     ****                                                                ADVNCE.74
C     ****     START OUT PREVIOUS LINE SOUTH                              ADVNCE.75
C     ****                                                                ADVNCE.76
      IF(J.NE.1)THEN                                                      ADVNCE.77
       DO I=1,IMAX*(KMAXP1*NHIST+1)                                       ADVNCE.78
        G(I,1,J-1)=F(I,NJOT)                                              ADVNCE.79
       ENDDO                                                              ADVNCE.80
      ENDIF                                                               ADVNCE.81
C     ****                                                                ADVNCE.82
C     ****     ADD DIAGNOSTIC QUANTITIES ONTO LINE J+2                    ADVNCE.83
C     ****                                                                ADVNCE.84
      IF(J.LE.JMAXM2)CALL N2ADDIAG(NTER)                                  ADVNCE.85
      IF(J.EQ.JMAX) IFRST=1                                               ADVNCE.86
C     ******************************************************************  ADVNCE.87
C     ****                                                                ADVNCE.88
C     ****                   DYNAMICS                                     ADVNCE.89
C     ****                                                                ADVNCE.90
C     ******************************************************************  ADVNCE.91
C     ****                                                                ADVNCE.92
C     ****     FOR J=1 AND JMAX USE BOUNDARY CONDITIONS                   ADVNCE.93
C     ****                                                                ADVNCE.94
      IF(J.EQ.1)THEN                                                      ADVNCE.95
       CALL N2CPKTKM                                                      ADVNCE.96
       CALL N2HDIF                                                        ADVNCE.97
       GO TO 6999                                                         ADVNCE.98
      ENDIF                                                               ADVNCE.99
      IF(J.EQ.JMAX)THEN                                                   ADVNCE.100
       GO TO 6999                                                         ADVNCE.101
      ENDIF                                                               ADVNCE.102
C     ****                                                                ADVNCE.103
C     ****    CALL TO BNDCMP SHOULD LEAD CALLS IN DYNAMICS SECTION OF     ADVNCE.104
C     ****      ADVNCE TO ENSURE THAT MATRICES B(ZIMXP,2,2) AND VECTORS   ADVNCE.105
C     ****      FB(ZIMXP,2) ARE AVAILABLE WHEN NEEDED                     ADVNCE.106
C     ****                                                                ADVNCE.107
      CALL N2BNDCMP                                                       ADVNCE.108
C     ****                                                                ADVNCE.109
C     ****    CALCULATE W AT N*DT                                         ADVNCE.110
C     ****                                                                ADVNCE.111
      CALL N2SWDOT(NTIME,LEVEL)                                           ADVNCE.112
C     ****                                                                ADVNCE.180
C     ****     CALCULATE ION DRIFT VELOCITIES                             ADVNCE.181
C     ****                                                                ADVNCE.182
c      CALL N2VDRIFT2                                                      ADVNCE.183
C     ****                                                                ADVNCE.184
C     ****     CALCULATE CP, KT, AND KM                                   ADVNCE.185
C     ****                                                                ADVNCE.186
      CALL N2CPKTKM                                                       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 N2CHAPMN                                                       ADVNCE.198
C     ****                                                                ADVNCE.199
C     ****     CALCULATE SOLAR HEATING                                    ADVNCE.200
C     ****     CALCULATE REACTION RATES                                   ADVNCE.201
C     ****                                                                ADVNCE.202
      CALL N2RATES                                                        ADVNCE.203
      CALL N2QRJ                                                          ADVNCE.204
C     ****                                                                ADVNCE.205
C     ****     CALCULATE BACKGROUND (NIGHT-TIME) IONIZATION               ADVNCE.206
C     ****                                                                ADVNCE.207
      CALL N2QINITE                                                       ADVNCE.208
C     ****                                                                ADVNCE.209
C     ****     ADD IONIZATION DUE TO SOLAR X-RAYS                         ADVNCE.210
C     ****                                                                ADVNCE.211
      CALL N2XRAY                                                         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 N2HEELIS(LEVEL)                                                ADVNCE.217
C     ****                                                                ADVNCE.218
C     ****     CALCULATE AURORAL ADDITIONS TO IONIZATION RATES            ADVNCE.219
C     ****                                                                ADVNCE.220
      CALL N2ORORA                                                        ADVNCE.221
C     ****                                                                ADVNCE.222
C     ****     SOLVE FOR N(O+)                                            ADVNCE.223
C     ****     SET FLUX AT UPPER BOUNDARY                                 ADVNCE.224
C     ****                                                                ADVNCE.225
      CALL N2OPFLUX(LEVEL)                                                ADVNCE.226
      CALL N2OPLUS(LEVEL,NTIME)                                           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 N2ELDEN                                                        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 N2LAMDAS                                                         ADVNCE.237
C     ****                                                                ADVNCE.238
C     ****     ROTATE LAMDAS TO GEOGRAPHIC SYSTEM                         ADVNCE.339
C     ****                                                                ADVNCE.340
      CALL N2ROTATE                                                       ADVNCE.341
C     ****                                                                ADVNCE.342
C     ****     ELECTRON PRODUCTION OF N4S AND N2D                         ADVNCE.343
C     ****                                                                ADVNCE.344
      CALL N2QTIEFF                                                       ADVNCE.345
C     ****                                                                ADVNCE.346
C     ****     ODD NITROGEN CHEMISTRY                                     ADVNCE.347
C     ****                                                                ADVNCE.348
      CALL N2CMPN2D                                                       ADVNCE.349
      CALL N2CMPN4S(LEVEL,NTIME)                                          ADVNCE.350
      CALL N2CMPNO(LEVEL,NTIME)                                           ADVNCE.351
      CALL N2CMPO2O                                                       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 N2QJNNO                                                        ADVNCE.357
      CALL N2QJION                                                        ADVNCE.358
C     ****                                                                ADVNCE.359
C     ****     CALCULATE ELECTRON AND ION TEMPERATURES                    ADVNCE.360
C     ****                                                                ADVNCE.361
      CALL N2SETTEI(LEVEL)                                                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 N2NEWTON                                                       ADVNCE.367
C     ****                                                                ADVNCE.368
C     ****     ADD IN O3P COOLING                                         ADVNCE.369
C     ****                                                                ADVNCE.370
      CALL N2NEWTO3P                                                      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 N2HDIF                                                         ADVNCE.376
C     ****                                                                ADVNCE.377
C     ****     ADVANCE T, U, V BY ONE TIME STEP                           ADVNCE.378
C     ****                                                                ADVNCE.379
      CALL N2DT(LEVEL,NTIME,NTER)                                         ADVNCE.380
      CALL N2DUV(LEVEL,NTIME,NTER)                                        ADVNCE.381
C     ****                                                                ADVNCE.382
C     ****     COMPOSITION OF MAJOR SPECIES                               ADVNCE.383
C     ****                                                                ADVNCE.384
      CALL N2COMP(LEVEL,NTIME)                                            ADVNCE.385
 6998 GOTO 3001                                                           ADVNCE.286
 6999 CONTINUE                                                            ADVNCE.287
C     ****                                                                ADVNCE.288
C     ****     FIND THE VARIBLES ON THE BOUNDARIES                        ADVNCE.289
C     ****                                                                ADVNCE.290
      IF(J.EQ.1)THEN                                                      ADVNCE.292
C       ****                                                              ADVNCE.292
C       ****     RADIATION BOUNDARY CONDITIONS                            ADVNCE.293
C       ****                                                              ADVNCE.294
c        CALL SBOUNDJ1                                                    ADVNCE.295
C       ****                                                              ADVNCE.296
C       ****     FIXED BOUNDARY CONDITIONS                                ADVNCE.297
C       ****                                                              ADVNCE.298
C        CALL FIX2                                                        ADVNCE.299
C       ****                                                              ADVNCE.300
C       ****     BOUNDARY VALUES FROM GENERAL CIRCULATION MODEL           ADVNCE.301
C       ****                                                              ADVNCE.302
        CALL N2NEBOUN1(NTIME)                                             ADVNCE.303
      ELSE                                                                ADVNCE.304
C       ****                                                              ADVNCE.305
C       ****     RADIATION BOUNDARY CONDITIONS                            ADVNCE.306
C       ****                                                              ADVNCE.307
C       CALL SBOUNDJM                                                     ADVNCE.308
C       ****                                                              ADVNCE.309
C       ****     FIXED BOUNDARY CONDITIONS                                ADVNCE.310
C       ****                                                              ADVNCE.311
C       CALL FIX2                                                         ADVNCE.312
C       ****                                                              ADVNCE.313
C       ****     BOUNDARY VALUES FROM GENERAL CIRCULATION MODEL           ADVNCE.314
C       ****                                                              ADVNCE.315
        CALL NEBOUN2(LEVEL,NTIME,NTER)                                    ADVNCE.316
      ENDIF                                                               ADVNCE.3
C     ******************************************************************  ADVNCE.386
C     ****                                                                ADVNCE.387
C     ****                   END OF DYNAMICS                              ADVNCE.388
C     ****                                                                ADVNCE.389
C     ******************************************************************  ADVNCE.390
C     ****                                                                ADVNCE.460
C     ****                   SPECIFY NESTED GRID BOUNDARy VALUES          ADVNCE.461
C     ****                                                                ADVNCE.462
3001  CONTINUE
c      NTERN=NTER-1
c      IF(NEST.EQ.1.AND.NTERN.GE.NES(2).AND.NTERN.LE.NEE(2))THEN
c       CALL N2BNDRY(J)
c       IF(J.GE.NESTJ1(2).AND.J.LE.NESTJM(2))THEN
c        CALL N2VIINTER(2)
c       ENDIF
c      ENDIF
 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,IMAX*(KMAXP1*NHIST+1)                                        ADVNCE.464
       G(I,1,J-1)=F(I,NJOT)                                               ADVNCE.465
      ENDDO                                                               ADVNCE.466
      IF(NTIME.LT.NESTRI(LEVEL)) GO TO 100                                ADVNCE.340
      RETURN                                                              ADVNCE.484
      END                                                                 ADVNCE.485
C                                                                         ADVNCE.486
*DK AURHT                                                                  AURHT.1
      SUBROUTINE N2AURHT(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 'n2param.h'                                                  AURHT.7
      INCLUDE 'n2const.h'                                                  AURHT.8
      include 'n2phycs.h'
      PARAMETER(IMX0=81)
      COMMON/N2ANGLE/ALON(IMX),COLAT(IMX)                                  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(IMX),DLON(IMX),ALFA(IMX),FLUX(IMX),ALFA2              AURHT.14
     1(IMX),FLUX2(IMX),DRIZL(IMX),WK2(IMX),WK3(IMX),WK1(IMX)               AURHT.15
      PI=3.1415926535898                                                   AURHT.16
c
c ** 04/27 modify --cmq
c
      ALFA0=2.5
      RALFA=0.1999999999960000
      IF (ALFA0 .GT. 0.01) THEN
      DO I=1,IM
      WK1(I)=DCOS(DATAN2(DSIN(ALON(I)-RROTE),DCOS(ALON(I)-RROTE)))
      WK2(I)=H0*(1-RH*DCOS(DATAN2(DSIN(ALON(I)-RROTH),
     1 DCOS(ALON(I)-RROTH))) )
      WK3(I) = COLAT(I) - RRAD(IHEM)
      ALFA(I) =  ALFA0*(1-RALFA*WK1(I))
      END DO
      ELSE
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
      END IF
      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 N2BDOTDH(PHIJM1,PHIJ,PHIJP1,J,ANS,IND)                   BDOTDH.2
C     ****                                                                BDOTDH.3
C     ****      EVALUATES  ANS = (B(H)*DEL(H))*PHI                        BDOTDH.4
C     ****                                                                BDOTDH.5
      include 'n2param.h'                                                 BDOTDH.6
      include 'n2const.h'                                                 BDOTDH.7
      COMMON/N2MAGFLD/BX(IMX,JMX),BY(IMX,JMX),BZ(IMX,JMX),BMOD(IMX,JMX)   BDOTDH.10
      DIMENSION PHIJM1(IMX,KMXP),PHIJ(IMX,KMXP),                          BDOTDH.11
     A PHIJP1(IMX,KMXP),ANS(IMX,KMXP)                                     BDOTDH.12
C     ****                                                                BDOTDH.13
C     ****    FOR J=2 NO PHIJM1 DATA                                      BDOTDH.14
C     ****                                                                BDOTDH.15
      IF(IND.EQ.-1)THEN                                                   BDOTDH.16
        DO K=1,KMAX                                                       BDOTDH.17
          DO I=2,LEN1-1                                                   BDOTDH.18
            ANS(I,K)=1./C(51)*(BX(I,J)/(CS(J)*2.*C(1))*(PHIJ(I+1,K)-      BDOTDH.19
     A               PHIJ(I-1,K))+BY(I,J)*(PHIJP1(I,K)-PHIJ(I,K))/C(2))   BDOTDH.20
          ENDDO                                                           BDOTDH.21
          ANS(1,K)=1./C(51)*(BX(1,J)/(CS(J)*C(1))*(PHIJ(2,K)-PHIJ(1,K))   BDOTDH.22
     A             +BY(1,J)*(PHIJP1(1,K)-PHIJ(1,K))/C(2))                 BDOTDH.23
          ANS(LEN1,K)=1./C(51)*(BX(LEN1,J)/(CS(J)*C(1))*(PHIJ(LEN1        BDOTDH.24
     A                ,K)-PHIJ(LEN1-1,K))+BY(LEN1,J)*(PHIJP1(LEN1         BDOTDH.25
     B                ,K)-PHIJ(LEN1,K))/C(2))                             BDOTDH.26
        ENDDO                                                             BDOTDH.27
C     ****                                                                BDOTDH.28
C     ****    FOR J=JMAXM1 NO PHIJP1 DATA                                 BDOTDH.29
C     ****                                                                BDOTDH.30
      ELSEIF(IND.EQ.1)THEN                                                BDOTDH.31
        DO K=1,KMAX                                                       BDOTDH.32
          DO I=2,LEN1-1                                                   BDOTDH.33
            ANS(I,K)=1./C(51)*(BX(I,J)/(CS(J)*2.*C(1))*(PHIJ(I+1,K)-      BDOTDH.34
     A               PHIJ(I-1,K))+BY(I,J)*(PHIJ(I,K)-PHIJM1(I,K))/C(2))   BDOTDH.35
          ENDDO                                                           BDOTDH.36
          ANS(1,K)=1./C(51)*(BX(1,J)/(CS(J)*C(1))*(PHIJ(2,K)-PHIJ(1,K))   BDOTDH.37
     A             +BY(1,J)*(PHIJ(1,K)-PHIJM1(1,K))/C(2))                 BDOTDH.38
          ANS(LEN1,K)=1./C(51)*(BX(LEN1,J)/(CS(J)*C(1))*(PHIJ(LEN1        BDOTDH.39
     A                ,K)-PHIJ(LEN1-1,K))+BY(LEN1,J)*(PHIJ(LEN1           BDOTDH.40
     B                ,K)-PHIJM1(LEN1,K))/C(2))                           BDOTDH.41
        ENDDO                                                             BDOTDH.42
C     ****                                                                BDOTDH.43
C     ****    FOR J > 2 AND J < JMAXM1                                    BDOTDH.44
C     ****                                                                BDOTDH.45
      ELSEIF(IND.EQ.0)THEN                                                BDOTDH.46
        DO K=1,KMAX                                                       BDOTDH.47
          DO I=2,LEN1-1                                                   BDOTDH.48
            ANS(I,K)=1./C(51)*(BX(I,J)/(CS(J)*2.*C(1))*(PHIJ(I+1,K)-      BDOTDH.49
     A        PHIJ(I-1,K))+BY(I,J)*(PHIJP1(I,K)-PHIJM1(I,K))/(2.*C(2)))   BDOTDH.50
          ENDDO                                                           BDOTDH.51
          ANS(1,K)=1./C(51)*(BX(1,J)/(CS(J)*C(1))*(PHIJ(2,K)-PHIJ(1,K))   BDOTDH.52
     A             +BY(1,J)*(PHIJP1(1,K)-PHIJM1(1,K))/2.*C(2))            BDOTDH.53
          ANS(LEN1,K)=1./C(51)*(BX(LEN1,J)/(CS(J)*C(1))*(PHIJ(LEN1        BDOTDH.54
     A                ,K)-PHIJ(LEN1-1,K))+BY(LEN1,J)*(PHIJP1(LEN1         BDOTDH.55
     B                ,K)-PHIJM1(LEN1,K))/2.*C(2))                        BDOTDH.56
        ENDDO                                                             BDOTDH.57
      ENDIF                                                               BDOTDH.58
      RETURN                                                              BDOTDH.59
      END                                                                 BDOTDH.60
C                                                                         BDOTDH.61
*DK BDZDVB                                                                BDZDVB.1
      SUBROUTINE N2BDZDVB(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 'n2param.h'                                                 BDZDVB.6
      include 'n2const.h'                                                 BDZDVB.7
      COMMON/N2MAGFLD/BX(IMX,JMX),BY(IMX,JMX),BZ(IMX,JMX),BMOD(IMX,JMX)
      DIMENSION PHI(IMX,KMXP),DVB(IMX),H(IMX,KMXP),                       BDZDVB.11
     A ANS(IMX,KMXP)                                                      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                                                                       BLOCKD.1
      BLOCK DATA N2CONSTS                                                 BLOCKD.2
      INCLUDE 'n2param.h'                                                 BLOCKD.3
      INCLUDE 'n2const.h'                                                 BLOCKD.4
      COMMON/N2INI/INITIAL,INIINPUT                                       BLOCKD.5
      REAL*8 NOB                                                           CMPNO.13
      COMMON/N2RUNT/TTBOUND,NOB(JMX),AVTO,HOR(JMX)                          CMPNO.14
      DATA INITIAL/0/,INIINPUT/0/                                                    BLOCKD.6
      DATA RMASS/32.,16.,28./                                               CON.14
      DATA CI/(0.0,1.0)/
C     ****                                                                RUNMDS.11
C     ****     VALUE OF T AT LOWER BOUNDARY                               RUNMDS.12
C     ****                                                                RUNMDS.13
      DATA TTBOUND/181./                                                  RUNMDS.14
C     ****                                                                RUNMDS.19
C     ****     N(NO) AT LOWER BOUNDARY, A FUNCTION OF LATITUDE            RUNMDS.20
C     ****       -- 36 VALUES                                             RUNMDS.21
C     ****                                                                RUNMDS.22
      DATA NOB/JMX*4.D6/                                                  RUNMDS.23
C     ****                                                                RUNMDS.24
C     ****     SET AVTO                                                   RUNMDS.25
C     ****                                                                RUNMDS.26
      DATA AVTO/1.D-12/                                                   RUNMDS.27
C     ****                                                                RUNMDS.28
C     ****     SET ARRAY GIVING HORIZONTAL VARIATION OF EDDY DIFFUSION    RUNMDS.29
C     ****     AND EDDY THERMAL CONDUCTIVITY.  IF VALUES ARE UNITY,       RUNMDS.30
C     ****     VALUE OF KE AT BOTTOM OF MODEL IS 5.D-6                    RUNMDS.31
C     ****                                                                RUNMDS.32
      DATA HOR/JMX*.5/                                                    RUNMDS.33
      END                                                                 BLOCKD.13
C                                                                         BLOCKD.14
*DK BNDCMP                                                                BNDCMP.1
      SUBROUTINE N2BNDCMP                                                 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 "n2param.h"                                                 BNDCMP.29
      INCLUDE "n2cvscr.h"                                                 BNDCMP.30
      INCLUDE "n2const.h"                                                 BNDCMP.31
      INCLUDE "index.h"                                                   BNDCMP.32
      INCLUDE "buffe.h"                                                   BNDCMP.33
      INCLUDE "n2cpbnd.h"                                                 BNDCMP.34
      DIMENSION EE(IMX,2,2),FF(IMX,2,2),GG(IMX,2),WM1(IMX,2,2),           BNDCMP.35
     1  WM2(IMX,2,2),WM3(IMX,2,2),WV1(IMX,2),WS1(IMX)                     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 N2BNDEF                                                        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 N2BNDEF                                                  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 "n2param.h"                                                 BNDEF.7
      INCLUDE "n2cvscr.h"                                                 BNDEF.8
      INCLUDE "index.h"                                                   BNDEF.9
      INCLUDE "buffe.h"                                                   BNDEF.10
      INCLUDE "n2phycs.h"                                                 BNDEF.11
      INCLUDE "n2const.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(IMX,2,2),FF(IMX,2,2),GG(IMX,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 CON                                                                      CON.1
      SUBROUTINE N2CON(NLEVEL,ASTEP)                                         CON.2
C     ****                                                                   CON.3
C     ****                   DEFINES THE MODEL CONSTANTS                     CON.4
C     ****                                                                   CON.5
      INCLUDE 'n2param.h'                                                    CON.6
      INCLUDE 'n2const.h'                                                    CON.7
      INCLUDE 'nestcnt.h'                                                    CON.9
      INCLUDE 'start.h'                                                      CON.10
      COMMON/C6/C61,C62                                                      CON.11
C     ****                                                                   CON.12
C     ****                   RESOLUTION PARAMETERS                           CON.13
C     ****                                                                   CON.14
      IMAX=IMX                                                               CON.15
      JMAX=JMX                                                               CON.16
      KMAX=KMX                                                               CON.17
      IMAXX=72                                                               CON.18
      JMAXX=36                                                               CON.19
C     ****                                                                   CON.20
C     ****                   DERIVED CONSTANTS                               CON.21
C     ****                                                                   CON.22
      PI=3.14159265358979                                                    CON.23
      DLAMDA=2.*PI/FLOAT(IMAXX)                                              CON.24
      DPHI=PI/FLOAT(JMAXX)                                                   CON.25
      RATIO=1                                                                CON.26
      DO N=1,NLEVEL                                                          CON.27
       RATIO=RATIO*DBLE(NESTRI(N))                                           CON.28
      ENDDO                                                                  CON.29
      DLAMDA=DLAMDA/RATIO                                                    CON.30
      DPHI=DPHI/RATIO                                                        CON.31
      DS=(ST-SB)/FLOAT(KMAX)                                                 CON.32
      JMAXM1=JMAX-1                                                          CON.33
      JMAXM2=JMAX-2                                                          CON.34
      KMAXM1=KMAX-1                                                          CON.35
      KMAXP1=KMAX+1                                                          CON.36
C     **** 								     CON.37
C     ****                   BUFFER INFORMATION                              CON.38
C     ****                   COMPUTE NUMBER OF FIELDS ON TAPE                CON.39
C     ****                   AND INITIALIZE POINTERS                         CON.40
C     ****                                                                   CON.41
      LEN1=IMAX                                                              CON.42
      LEN2=IMAX*KMAX                                                         CON.43
      LEN3=IMAX*KMAXP1                                                       CON.44
C     ****                                                                   CON.45
C     ****                  COMPUTE PHI VARIATION ARRAYS                     CON.46
C     ****                                                                   CON.47
      OMEGA=7.292E-5                                                         CON.48
      DO J=1,JMAX                                                            CON.49
       PHI=PHIS(2)*PI/180.+FLOAT(J-1)*DPHI                                   CON.50
       CS(J)=DCOS(PHI)                                                       CON.51
       SN(J)=DSIN(PHI)                                                       CON.52
       TN(J)=DTAN(PHI)                                                       CON.53
       COR(J)=2.*OMEGA*SN(J)                                                 CON.54
      ENDDO                                                                  CON.55
C     ****                                                                   CON.56
C     ****     CALCULATE SUN'S DECLINATION                                   CON.57
C     ****                                                                   CON.58
      DELTA=DATAN(DTAN(23.5*PI/180.)*DSIN(2.*PI*DBLE(IIDAY-80)/365.))        CON.59
C     ****                                                                   CON.60
C     ****                   GRID CONSTANTS                                  CON.61
C     ****                                                                   CON.62
      C(1)=DLAMDA                                                            CON.63
      C(2)=DPHI                                                              CON.64
      C(3)=DS                                                                CON.65
      C(4)=ASTEP/DBLE(NESTRI(NLEVEL))                                        CON.66
      C(6)=2.*C(4)                                                           CON.67
      C(7)=1./C(6)                                                           CON.68
C     ****                                                                   CON.69
C     ****                   FINITE DIFFERENCE OPERATOR CONSTANTS            CON.70
C     ****                                                                   CON.71
      C(10)=2./(3.*DLAMDA)                                                   CON.72
      C(11)=1./(12.*DLAMDA)                                                  CON.72
      C(12)=2./(3.*DPHI)                                                     CON.73
      C(13)=1./(12.*DPHI)                                                    CON.74
      C(14)=1./(2.*DLAMDA)                                                   CON.75
      C(15)=1./(2.*DPHI)                                                     CON.76
C     ****                                                                   CON.77
C     ****     INTEGRATION CONSTANTS                                         CON.78
C     ****                                                                   CON.79
      C(18)=C(3)/(1.+.5*C(3))                                                CON.80
      C(19)=(1.-.5*C(3))/(1.+.5*C(3))                                        CON.81
      C(20)=1./DS                                                            CON.82
      C(22)=DCOS(PI/3.)                                                      CON.83
      C(23)=4.*PI/(24.*60.*60.)                                              CON.84
      C(24)=28.9                                                             CON.85
C     ****                                                                   CON.86
C     ****     ANNUAL FREQUENCY                                              CON.87
C     ****                                                                   CON.88
      C(25)=C(23)/(2.*365.25)                                                CON.89
C     ****                                                                   CON.90
C     ****     SHAPIRO SMOOTHER CONSTANT                                     CON.91
C     ****                                                                   CON.92
      C(26)=3.0D-2                                                           CON.93
C     ****                                                                   CON.94
C     ****     EDDY DIFFUSION                                                CON.95
C     ****                                                                   CON.96
      C(27)=5.D-6                                                            CON.97
C     ****                                                                   CON.98
C     ****     EDDY THERMAL CONDUCTION                                       CON.99
C     ****                                                                   CON.100
      C(28)=C(27)                                                            CON.101
C     ****                                                                   CON.102
C     ****                   TIME SMOOTHING CONSTANT                         CON.103
C     ****                                                                   CON.104
      ALPHA=.95                                                              CON.105
      C(30)=ALPHA                                                            CON.106
      C(31)=.5*(1.-ALPHA)                                                    CON.107
C     ****                                                                   CON.108
C     ****     SURPLUS HEAT PER EVENT CONVERTED FROM E.V. TO ERGS            CON.109
C     ****                                                                   CON.110
      C(45)=5.11*1.602D-12                                                   CON.111
C     ****                                                                   CON.112
C     ****                   PHYSICAL CONSTANTS                              CON.113
C     ****                                                                   CON.114
C    ****                        EARTHS RADIUS                               CON.115
C     ****                                                                   CON.116
      C(51)=6.37122E8                                                        CON.117
      C(52)=1./C(51)                                                         CON.118
      C(53)=C(51)*C(51)                                                      CON.119
C     ****                                                                   CON.120
C                                 GRAVITATIONAL CONSTANT                     CON.121
C     ****                                                                   CON.122
      C(54)=870.                                                             CON.123
      C(55)=1./C(54)                                                         CON.124
C     ****                                                                   CON.125
C                                 EARTHS ANGULAR VELOCITY                    CON.126
C     ****                                                                   CON.127
      C(56)=OMEGA                                                            CON.128
C     ****                                                                   CON.129
C                                 GAS CONSTANT                               CON.130
C     ****                                                                   CON.131
      C(57)=8.314D7                                                          CON.132
C     ****                                                                   CON.133
C     ****     H*C                                                           CON.134
C     ****                                                                   CON.135
      C(60)=1.9845D-16                                                       CON.136
C     ****                                                                   CON.137
C     ****     F10.7                                                         CON.138
C     ****                                                                   CON.139
      C(61)=C61                                                              CON.140
      C(62)=C62                                                              CON.141
C     ****                                                                   CON.142
C     ****                        G/R                                        CON.143
C     ****                                                                   CON.144
      C(65)=C(54)/C(57)                                                      CON.145
C     ****                                                                   CON.146
C     ****     STANDARD PRESSURE                                             CON.147
C     ****                                                                   CON.148
      C(81)=5.0D-4                                                           CON.149
C     ****                                                                   CON.150
C     ****     BOLTZMANN CONST                                               CON.151
C     ****                                                                   CON.152
      C(84)=1.38D-16                                                         CON.153
C     ****                                                                   CON.154
C     ****     AVOGRADO NUMBER                                               CON.155
C     ****                                                                   CON.156
      C(85)=6.023D23                                                         CON.157
C     ****                                                                   CON.158
C     ****     EXP(-.5*DS)                                                   CON.159
C     ****                                                                   CON.160
      C(86)=DEXP(-.5*DS)                                                     CON.161
C     ****                                                                   CON.162
C     ****     EXP(.5*DS)                                                    CON.163
C     ****                                                                   CON.164
      C(87)=1./C(86)                                                         CON.165
C     ****                                                                   CON.166
C     ****     SUN'S DECLINATION:                                            CON.167
C     ****                                                                   CON.168
      C(95)=DSIN(DELTA)                                                      CON.169
      C(96)=DCOS(DELTA)                                                      CON.170
C     ****                                                                   CON.171
C     ****                   KO  COEFFICIENT OF EDDY VISCOSITY               CON.172
C     ****                                                                   CON.173
      C(109)=0.2                                                             CON.174
      C(110)=PI                                                              CON.175
C     ****                                                                   CON.176
C     ****         SAVE ORIGINAL DT VALUE                                    CON.177
C     ****                                                                   CON.178
      C(112)=DSQRT(PI)                                                       CON.179
C     ****                                                                   CON.180
C     ****     CALCULATE EXPS AND A ARRAYS                                   CON.181
C     ****                                                                   CON.182
      S=SB+.5*DS                                                             CON.183
      EXPS(1)=DEXP(-S)                                                       CON.184
      EXPDS=DEXP(-DS)                                                        CON.185
      DIFK(1)=C(27)                                                          CON.186
      DIFT(1)=C(28)                                                          CON.187
      XMUE(1)=C(27)                                                          CON.188
      DO K=2,KMAX                                                            CON.189
       EXPS(K)=EXPS(K-1)*EXPDS                                               CON.190
       DIFK(K)=DIFK(K-1)*EXPDS                                               CON.191
       DIFT(K)=DIFT(K-1)*EXPDS                                               CON.192
       XMUE(K)=DIFK(K)                                                       CON.193
      ENDDO                                                                  CON.194
      DIFK(KMAXP1)=DIFK(KMAX)*EXPDS                                          CON.195
      DIFT(KMAXP1)=DIFT(KMAX)                                                CON.196
      XMUE(KMAXP1)=DIFK(KMAXP1)                                              CON.197
      RETURN                                                                 CON.198
      END                                                                    CON.200
C                                                                            CON.201
*DK CHAPMN                                                                CHAPMN.1
      SUBROUTINE N2CHAPMN                                                 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 'n2param.h'                                                 CHAPMN.7
      INCLUDE 'n2array.h'                                                 CHAPMN.7
      INCLUDE 'n2cvscr.h'                                                 CHAPMN.8
      INCLUDE 'n2const.h'                                                 CHAPMN.9
      INCLUDE 'index.h'                                                   CHAPMN.10
      INCLUDE 'buffe.h'                                                   CHAPMN.11
      INCLUDE 'n2phycs.h'                                                 CHAPMN.12
      INCLUDE 'start.h'                                                   CHAPMN.13
      INCLUDE 'nestcnt.h'
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=PHIS(2)*C(110)/180.+DBLE(J-1)*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.D0+(2.*C(110)+SLAM(2)*C(110)/180.+
     1      DBLE(I-1)*C(1))*12.D0/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.D0))                                         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)*5.6498823D-1/
     1           (6.651874D-2+S5(I,1))                                    CHAPMN.137
        ELSE                                                              CHAPMN.138
         S5(I,1)=S7(I,1)*C(112)*S6(I,1)*(1.0606963D0+5.564383D-1*         CHAPMN.139
     1           S5(I,1))/((S5(I,1)+1.7245609D0)*S5(I,1)+1.0619896D0)     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 N2CMPN2D                                                 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 'n2param.h'                                                 CMPN2D.7
      INCLUDE 'n2array.h'                                                 CMPN2D.7
      INCLUDE 'n2cvscr.h'                                                 CMPN2D.8
      INCLUDE 'n2const.h'                                                 CMPN2D.9
      INCLUDE 'index.h'                                                   CMPN2D.10
      INCLUDE 'buffe.h'                                                   CMPN2D.11
      INCLUDE 'n2rates.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 N2CMPN4S(LEVEL,NTIME)                                    CMPN4S.2
C     ****                                                                CMPN4S.3
C     ****     ADVANCES PSI(N4S) BY ONE TIME STEP                         CMPN4S.4
C     ****                                                                CMPN4S.5
      INCLUDE 'n2param.h'                                                 CMPN4S.6
      INCLUDE 'n2array.h'                                                 CMPN2D.7
      INCLUDE 'n2cvscr.h'                                                 CMPN4S.7
      INCLUDE 'n2const.h'                                                 CMPN4S.8
      INCLUDE 'index.h'                                                   CMPN4S.9
      INCLUDE 'buffe.h'                                                   CMPN4S.10
      INCLUDE 'n2rates.h'                                                 CMPN4S.11
      include 'n2phycs.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 N2MINOR(NPN4S,NN4SNM,RMN4S,PHIN4S,ALFA,IBND,IBNDB,LEVEL,       CMPN4S.107
     1             NTIME)                                                 CMPN4S.102
      RETURN                                                              CMPN4S.103
      END                                                                 CMPN4S.104
C                                                                         CMPN4S.105
*DK CMPNO                                                                  CMPNO.1
      SUBROUTINE N2CMPNO(LEVEL,NTIME)                                      CMPNO.2
C     ****                                                                 CMPNO.3
C     ****     ADVANCES PSI(NO) BY ONE TIME STEP                           CMPNO.4
C     ****                                                                 CMPNO.5
      INCLUDE 'n2param.h'                                                  CMPNO.6
      INCLUDE 'n2array.h'                                                  CMPN2D.7
      INCLUDE 'n2cvscr.h'                                                  CMPNO.7
      INCLUDE 'n2const.h'                                                  CMPNO.8
      INCLUDE 'index.h'                                                    CMPNO.9
      INCLUDE 'buffe.h'                                                    CMPNO.10
      INCLUDE 'n2rates.h'                                                  CMPNO.11
      INCLUDE 'n2phycs.h'                                                  CMPNO.12
      REAL*8 NOB,NNOB                                                      CMPNO.13
      COMMON/N2RUNT/TTBOUND,NOB(JMX),AVTO,HOR(JMX)                          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 N2MINOR(NPNO,NPNONM,RMNO,PHINO,ALFA,IBND,IBNDB,LEVEL,NTIME)     CMPNO.81
      RETURN                                                               CMPNO.82
      END                                                                  CMPNO.83
C                                                                          CMPNO.84
*DK                                                                       CMPO2O.1
      SUBROUTINE N2CMPO2O                                                 CMPO2O.2
C     ****                                                                CMPO2O.3
C     ****     CALCULATES FS ARRAY WHICH GIVES SOURCES AND SINK FOR COMP  CMPO2O.4
C     ****                                                                CMPO2O.5
      INCLUDE "n2param.h"                                                 CMPO2O.6
      INCLUDE "n2cvscr.h"                                                 CMPO2O.7
      INCLUDE "n2const.h"                                                 CMPO2O.8
      INCLUDE 'n2array.h'                                                 CMPN2D.7
      INCLUDE "index.h"                                                   CMPO2O.9
      INCLUDE "buffe.h"                                                   CMPO2O.10
      INCLUDE "n2rates.h"                                                 CMPO2O.11
      COMMON/FSARAY2/FS(IMX,KMXP,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 N2COMP(LEVEL,NTIME)                                        COMP.2
C     ****                                                                  COMP.3
C     ****     ADVANCE PSI IN TIME                                          COMP.4
C     ****                                                                  COMP.5
      INCLUDE 'n2param.h'                                                   COMP.6
      INCLUDE 'n2array.h'                                                   CMPN2D.7
      INCLUDE 'start.h'                                                     COMP.7
      INCLUDE 'n2ccomp.h'                                                   COMP.8
      INCLUDE 'n2const.h'                                                   COMP.9
      INCLUDE 'index.h'                                                     COMP.10
      INCLUDE 'buffe.h'                                                     COMP.11
      INCLUDE 'n2phycs.h'                                                   COMP.12
      INCLUDE 'n2cpbnd.h'                                                   COMP.13
      COMMON/FSARAY2/FS(IMX,KMXP,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 N2DFACT(T1,J,IMAX)                                 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       pause
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 N2ADVECL(NPSL,FK(1,L),K)                                       COMP.196   
        CALL N2ADVECL2(NPSL,FK(1,L),K)                                      COMP.1
        CALL N2FILTER2(FK(1,L),J,1,LEVEL)
       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
        IF(J.GT.2.AND.J.LT.JMAXM1)THEN                                      COMP.208
         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
        ELSE                                                                COMP.213
         DO I=1,LEN1                                                        COMP.214   
          WKV1(I,L)=F(I,NPSNMK)-C(26)*(-4.*(F(I,NPJP1K)+F(I,NPJM1K))        COMP.215
     1              +8.*F(I,NPSNMK))                                        COMP.216
         ENDDO                                                              COMP.217
        ENDIF                                                               COMP.218
       ENDDO                                                                COMP.194
       DO L=1,2                                                             COMP.194
        DO I=3,LEN1-2                                                       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
        WKV2(2,L)=WKV1(2,L)-C(26)*(-4.*(WKV1(3,L)+WKV1(1,L))+               COMP.225
     1            8.*WKV1(2,L))                                             COMP.226
        WKV2(LEN1-1,L)=WKV1(LEN1-1,L)-C(26)*(-4.*(WKV1(LEN1,L)+             COMP.227
     1                 WKV1(LEN1-2,L))+8.*WKV1(LEN1-1,L))                   COMP.228
       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=1,IMAX                                                         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
       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.
C     ****     BOUNDARY VALUES FROM GENERAL CIRCULATION MODEL               COMP.
C     ****                                                                  COMP.
      CALL N2NESTBOUN(J,NPS,LEVEL,NTIME)                                      COMP.
      CALL N2NESTBOUN(J,NPS2,LEVEL,NTIME)                                     COMP.
C     ****                                                                  COMP.396 
C     ****     TIME SMOOTHING OF PSI                                        COMP.397
C     ****                                                                  COMP.398   
      CALL N2SHAPIRO2(NPS, KMAXP1)
      CALL N2SHAPIRO2(NPS2,KMAXP1)
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.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 N2CPKTKM                                                 CPKTKM.2
C     ****                                                                CPKTKM.3
C     ****     CALCULATES CP, KT AND KM                                   CPKTKM.4
C     ****                                                                CPKTKM.5
      INCLUDE 'n2param.h'                                                 CPKTKM.6
      INCLUDE 'n2array.h'                                                 CPKTKM.7
      INCLUDE 'n2const.h'                                                 CPKTKM.8
      INCLUDE 'index.h'                                                   CPKTKM.9
      INCLUDE 'buffe.h'                                                   CPKTKM.10
      NPS1K=NJ+NPS                                                        CPKTKM.11
      NPS2K=NPS1K+KMAXP1                                                  CPKTKM.12
      NCPK=NCP                                                            CPKTKM.13
      NKTK=NKT                                                            CPKTKM.14
      NKMK=NKM                                                            CPKTKM.15
      DO I=1,LEN3                                                         CPKTKM.16
       PMBAR=1./(F(I,NPS1K)/RMASS(1)+F(I,NPS2K)/RMASS(2)+                 CPKTKM.17
     1       (1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3))                         CPKTKM.18
       PO2=PMBAR*F(I,NPS1K)/RMASS(1)                                      CPKTKM.19
       PO=PMBAR*F(I,NPS2K)/RMASS(2)                                       CPKTKM.20
       PN2=1.-PO2-PO                                                      CPKTKM.21
C      ****                                                               CPKTKM.22
C      ****     CP=R/2.*(PO2*7./32.+PN2*7./28.+PO*5./16.)                 CPKTKM.23
C      ****     KM=(PO2*4.03+PN2*3.42+PO*3.9)                             CPKTKM.24
C      ****     KT=(PO2+PN2)*56.+PO*75.9                                  CPKTKM.25
C      ****                                                               CPKTKM.26
       F(I,NCPK)=C(57)*.5*(PO2*7./32.+PN2*7./28.+PO*5./16.)               CPKTKM.27
       F(I,NKMK)=PO2*4.03+PN2*3.42+PO*3.9                                 CPKTKM.28
       F(I,NKTK)=(PO2+PN2)*56.+PO*75.9                                    CPKTKM.29
      ENDDO                                                               CPKTKM.30
      NTK=NJ+NT-1                                                         CPKTKM.31
      NKTK=NKTK-1                                                         CPKTKM.32
      NKMK=NKMK-1                                                         CPKTKM.33
      DO K=1,KMAX                                                         CPKTKM.34
       NKTK=NKTK+1                                                        CPKTKM.35
       NKMK=NKMK+1                                                        CPKTKM.36
       NTK=NTK+1                                                          CPKTKM.37
       DO I=1,LEN1                                                        CPKTKM.38
        F(I,NKMK)=F(I,NKMK)*F(I,NTK)**0.69*1.D-6                          CPKTKM.39
        F(I,NKTK)=F(I,NKTK)*F(I,NTK)**0.69                                CPKTKM.40
       ENDDO                                                              CPKTKM.41
      ENDDO                                                               CPKTKM.42
      NKTK=NKTK+1                                                         CPKTKM.43
      NKMK=NKMK+1                                                         CPKTKM.44
      DO I=1,LEN1                                                         CPKTKM.45
       F(I,NKMK)=F(I,NKMK)*F(I,NTK)**0.69*1.D-6                           CPKTKM.46
       F(I,NKTK)=F(I,NKTK)*F(I,NTK)**0.69                                 CPKTKM.47
      ENDDO                                                               CPKTKM.48
      NKMK=NKMK+1                                                         CPKTKM.49
      NKTK=NKTK+1                                                         CPKTKM.50
      NCPK=NCPK+KMAXP1                                                    CPKTKM.51
      DO K=1,KMAX                                                         CPKTKM.52
       NKMK=NKMK-1                                                        CPKTKM.53
       NKTK=NKTK-1                                                        CPKTKM.54
       NCPK=NCPK-1                                                        CPKTKM.55
       DO I=1,LEN1                                                        CPKTKM.56
        F(I,NCPK)=.5*(F(I,NCPK)+F(I,NCPK-1))                              CPKTKM.57
        F(I,NKMK)=.5*(F(I,NKMK)+F(I,NKMK-1))                              CPKTKM.58
        F(I,NKTK)=.5*(F(I,NKTK)+F(I,NKTK-1))                              CPKTKM.59
       ENDDO                                                              CPKTKM.60
      ENDDO                                                               CPKTKM.61
      DO I=1,LEN1                                                         CPKTKM.62
       F(I,NCPK-1)=2.*F(I,NCPK-1)-F(I,NCPK)                               CPKTKM.63
       F(I,NKMK-1)=2.*F(I,NKMK-1)-F(I,NKMK)                               CPKTKM.64
       F(I,NKTK-1)=2.*F(I,NKTK-1)-F(I,NKTK)                               CPKTKM.65
      ENDDO                                                               CPKTKM.66
      RETURN                                                              CPKTKM.67
      END                                                                 CPKTKM.68
*DK DFACT                                                                  DFACT.1
      SUBROUTINE N2DFACT(T,J,LEN,LEVEL)                                    DFACT.2
      INCLUDE 'n2param.h'                                                  DFACT.3
      INCLUDE 'n2const.h'                                                  DFACT.4
      INCLUDE 'nestcnt.h'
      DIMENSION T(1)                                                       DFACT.5
      REAL*8 NOB                                                           DFACT.6
      COMMON/N2RUNT/TTBOUND,NOB(JMX),AVTO,HOR(JMX)                         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=PHIS(LEVEL)*C(110)/180.+DBLE(J-1)*C(2)                  
      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 N2DIFFUS(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 'n2param.h'                                                 DIFFUS.6     
      include 'n2const.h'                                                 DIFFUS.7     
      DIMENSION TP(IMX,KMXP),EN(IMX,KMXP),H(IMX,KMXP),                    DIFFUS.8     
     A ANS(IMX,KMXP)                                                      DIFFUS.9    
      DATA RMOP/16./                                                      DIFFUS.10 
      MGR=RMOP*C(54)/C(57)                                                DIFFUS.11    
      DO K=2,KMAXM1                                                       DIFFUS.12
        DO I=1,LEN1                                                       DIFFUS.13 
          ANS(I,K)=1./(2.*H(I,K)*C(3))*(TP(I,K+1)*EN(I,K+1)-TP(I,K-1)     DIFFUS.14    
     A   *EN(I,K-1))+MGR*EN(I,K)                                          DIFFUS.15    
        ENDDO                                                             DIFFUS.16
      ENDDO                                                               DIFFUS.17 
C     ****                                                                DIFFUS.18    
C     ****      UPPER AND LOWER BOUNDARIES                                DIFFUS.19    
C     ****                                                                DIFFUS.20    
      DO I=1,LEN1                                                         DIFFUS.21    
        ANS(I,KMAX) = 1./(H(I,KMAX)*C(3))*(TP(I,KMAX)*EN(I,KMAX)-         DIFFUS.22    
     A   TP(I,KMAXM1)*EN(I,KMAXM1))+MGR*EN(I,KMAX)                        DIFFUS.23    
        ANS(I,1) = 1./(H(I,1)*C(3))*(TP(I,2)*EN(I,2)-                     DIFFUS.24    
     A   TP(I,1)*EN(I,1))+MGR*EN(I,1)                                     DIFFUS.25    
      ENDDO                                                               DIFFUS.26    
      RETURN                                                              DIFFUS.27    
      END                                                                 DIFFUS.28    
C                                                                         DIFFUS.29
DK DIVB                                                                    DIVB.1     
      SUBROUTINE N2DIVB(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 'n2param.h'                                                   DIVB.7     
      include 'n2const.h'                                                   DIVB.8     
      COMMON/N2MAGFLD/BX(IMX,JMX),BY(IMX,JMX),BZ(IMX,JMX),BMOD(IMX,JMX)
      DIMENSION DVB(IMX)                                                    DIVB.12    
      DO I=2,LEN1-1                                                         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    
        DVB(1)=(((BX(2,J)-BX(1,J))/C(1)+(CS(J+1)*BY(1,J+1)-                 DIVB.14    
     A         CS(J-1)*BY(1,J-1))/(2.*C(2)))/CS(J)+2.*BZ(1,J))/C(51)        DIVB.15    
        DVB(LEN1)=(((BX(LEN1,J)-BX(LEN1-1,J))/C(1)+(CS(J+1)*BY(LEN1,        DIVB.16
     A            J+1)-CS(J-1)*BY(LEN1,J-1))/(2.*C(2)))/CS(J)+2.*           DIVB.17
     B            BZ(LEN1,J))/C(51)                                         DIVB.18    
      ENDDO                                                                 DIVB.19    
      RETURN                                                                DIVB.20    
      END                                                                   DIVB.21    
C                                                                           DIVB.22 
*DK DIVRG                                                                  DIVRG.1 
      SUBROUTINE N2DIVRG(S)                                                DIVRG.2     
      include 'n2param.h'                                                  DIVRG.3
      include 'n2array.h'                                                  DIVRG.4
      include 'buffe.h'                                                    DIVRG.5
      include 'n2const.h'                                                  DIVRG.6
      include 'index.h'                                                    DIVRG.7
      include 'n2phycs.h'                                                  DIVRG.8
      DIMENSION S(IMX,KMXP),D2U(IMX,KMXP),D4U(IMX,KMXP),DVC(IMX,KMXP)      DIVRG.9
C     ****                                                                 DIVRG.10
C     ****                   COMPUTE D(U)/DLAMDA                           DIVRG.11   
C     ****                                                                 DIVRG.12 
      IF(J.NE.2.AND.J.NE.JMAX-1)THEN                                       DIVRG.13
C       ****                                                               DIVRG.14
C       ****                   D2U=(U(I+1)-U(I-1))*C(10)                   DIVRG.15
C       ****                   D4U=(U(I+2)-U(I-2))*C(11)                   DIVRG.16
C       ****                                                               DIVRG.17
        NUK=NJ+NU                                                          DIVRG.18
        DO K=1,KMAX                                                        DIVRG.19
          DO I=3,LEN1-2                                                    DIVRG.20
            D2U(I,K)=(F(I+1,NUK)-F(I-1,NUK))*C(10)                         DIVRG.21
            D4U(I,K)=(F(I+2,NUK)-F(I-2,NUK))*C(11)                         DIVRG.22
          ENDDO                                                            DIVRG.23
          NUK=NUK+1                                                        DIVRG.24
        ENDDO                                                              DIVRG.25
C       ****                                                               DIVRG.26
C       ****                   DVC=(VCJP1(I)-VCJM1(I))*C(12)               DIVRG.27
C       ****                   S=D2U-D4U+DVC                               DIVRG.28
        NVCPK=NJP1+NVC                                                     DIVRG.29
        NVCMK=NJM1+NVC                                                     DIVRG.30
        DO K=1,KMAX                                                        DIVRG.31
          DO I=3,LEN1-2                                                    DIVRG.32
      	    DVC(I,K)=(F(I,NVCPK)-F(I,NVCMK))*C(12)                         DIVRG.33
            S(I,K)=D2U(I,K)-D4U(I,K)+DVC(I,K)                              DIVRG.34
          ENDDO                                                            DIVRG.35
          NVCPK=NVCPK+1                                                    DIVRG.36
          NVCMK=NVCMK+1                                                    DIVRG.37
        ENDDO                                                              DIVRG.38
C       ****                                                               DIVRG.39
C       ****                   DVC=(VCJP2(I)-VCJM2(I))*C(13)               DIVRG.40
C       ****                   S=(S-DVC)*RACS                              DIVRG.41
C       ****                                                               DIVRG.42
        NVCPK=NJP2+NVC                                                     DIVRG.43
        NVCMK=NJM2+NVC                                                     DIVRG.44
        DO K=1,KMAX                                                        DIVRG.45
          DO I=3,LEN1-2                                                    DIVRG.46
            DVC(I,K)=(F(I,NVCPK)-F(I,NVCMK))*C(13)                         DIVRG.47
            S(I,K)=(S(I,K)-DVC(I,K))*RACS                                  DIVRG.48
          ENDDO                                                            DIVRG.49
          NVCPK=NVCPK+1                                                    DIVRG.50
          NVCMK=NVCMK+1                                                    DIVRG.51
        ENDDO                                                              DIVRG.52
        NUK=NJ+NU                                                          DIVRG.53
        NVCPK=NJP1+NVC                                                     DIVRG.54
        NVCMK=NJM1+NVC                                                     DIVRG.55
        DO K=1,KMAX                                                        DIVRG.56
          D2U(1,K)=(F(2,NUK)-F(1,NUK))*C(10)*3./2.                         
          D2U(2,K)=(F(3,NUK)-F(1,NUK))*C(10)*3./4.                         DIVRG.57
          D2U(LEN1-1,K)=(F(LEN1,NUK)-F(LEN1-2,NUK))*C(10)*3./4.            DIVRG.58
          D2U(LEN1,K)=(F(LEN1,NUK)-F(LEN1-1,NUK))*C(10)*3./2.
          DVC(1,K)=(F(1,NVCPK)-F(1,NVCMK))*C(12)*3./4.                     
          DVC(2,K)=(F(2,NVCPK)-F(2,NVCMK))*C(12)*3./4.                     DIVRG.59
          DVC(LEN1-1,K)=(F(LEN1-1,NVCPK)-F(LEN1-1,NVCMK))*                 DIVRG.60
     1                  C(12)*3./4.                                        DIVRG.61
          DVC(LEN1,K)=(F(LEN1,NVCPK)-F(LEN1,NVCMK))*C(12)*3./4.
          S(1,K)=(D2U(1,K)+DVC(1,K))*RACS
          S(2,K)=(D2U(2,K)+DVC(2,K))*RACS                                  DIVRG.62
          S(LEN1-1,K)=(D2U(LEN1-1,K)+DVC(LEN1-1,K))*RACS                   DIVRG.63
          S(LEN1,K)=(D2U(LEN1,K)+DVC(LEN1,K))*RACS                         DIVRG.63
          NUK=NUK+1                                                        DIVRG.64
          NVCPK=NVCPK+1                                                    DIVRG.65
          NVCMK=NVCMK+1                                                    DIVRG.66
        ENDDO                                                              DIVRG.67
      ELSE                                                                 DIVRG.68
        NUK=NJ+NU                                                          DIVRG.69
        NVCPK=NJP1+NVC                                                     DIVRG.70
        NVCMK=NJM1+NVC                                                     DIVRG.71
        DO K=1,KMAX                                                        DIVRG.72
          DO I=2,LEN1-1                                                    DIVRG.73
            D2U(I,K)=(F(I+1,NUK)-F(I-1,NUK))*C(10)*3./4.                   DIVRG.74
            DVC(I,K)=(F(I,NVCPK)-F(I,NVCMK))*C(12)*3./4.                   DIVRG.75
            S(I,K)=(D2U(I,K)+DVC(I,K))*RACS                                DIVRG.76
          ENDDO                                                            DIVRG.77
            D2U(1,K)=(F(2,NUK)-F(1,NUK))*C(10)*3./2.
            DVC(1,K)=(F(1,NVCPK)-F(1,NVCMK))*C(12)*3./4.
            S(1,K)=(D2U(1,K)+DVC(1,K))*RACS
            D2U(LEN1,K)=(F(LEN1,NUK)-F(LEN1-1,NUK))*C(10)*3./2.
            DVC(LEN1,K)=(F(LEN1,NVCPK)-F(LEN1,NVCMK))*C(12)*3./4.
            S(LEN1,K)=(D2U(LEN1,K)+DVC(LEN1,K))*RACS
          NUK=NUK+1                                                        DIVRG.78
          NVCPK=NVCPK+1                                                    DIVRG.79
          NVCMK=NVCMK+1                                                    DIVRG.80
        ENDDO                                                              DIVRG.81
      ENDIF                                                                DIVRG.82
      RETURN                                                               DIVRG.83
      END                                                                  DIVRG.84
C                                                                          DIVRG.85
*DK DIVRG1                                                                DIVRG1.1 
      SUBROUTINE N2DIVRG1(S)                                              DIVRG1.2   
      include 'n2param.h'                                                 DIVRG1.3
      include 'n2array.h'                                                 DIVRG1.4
      include 'buffe.h'                                                   DIVRG1.5
      include 'n2const.h'                                                 DIVRG1.6
      include 'index.h'                                                   DIVRG1.7
      include 'n2phycs.h'                                                 DIVRG1.8
      DIMENSION S(IMX,KMXP),D2U(IMX,KMXP),DVC(IMX,KMXP)                   DIVRG1.9
C     ****                                                                DIVRG1.10
C     ****                   COMPUTE D(U)/DLAMDA                          DIVRG1.11  
C     ****                                                                DIVRG1.12 
      IF(J.EQ.1)THEN                                                      DIVRG1.13
        NUK=NJ+NU                                                         DIVRG1.14
        NVCPK=NJP1+NVC                                                    DIVRG1.15
        NVCK=NJ+NVC                                                       DIVRG1.16
        DO K=1,KMAX                                                       DIVRG1.17
          DO I=2,LEN1-1                                                   DIVRG1.18
            D2U(I,K)=(F(I+1,NUK)-F(I-1,NUK))*C(10)*3./2.                  DIVRG1.19
            DVC(I,K)=(F(I,NVCPK)-F(I,NVCK))*C(12)*3./2.                   DIVRG1.20
            S(I,K)=(D2U(I,K)+DVC(I,K))*RACS                               DIVRG1.21
          ENDDO                                                           DIVRG1.22
            D2U(1,K)=(F(2,NUK)-F(1,NUK))*C(10)*3./2.                      DIVRG1.23
            DVC(1,K)=(F(1,NVCPK)-F(1,NVCK))*C(12)*3./2.                   DIVRG1.24
            S(1,K)=(D2U(1,K)+DVC(1,K))*RACS                               DIVRG1.25   
            D2U(LEN1,K)=(F(LEN1,NUK)-F(LEN1-1,NUK))*C(10)*3./2.           DIVRG1.26
            DVC(LEN1,K)=(F(LEN1,NVCPK)-F(LEN1,NVCK))*C(12)*3./2.          DIVRG1.27
            S(LEN1,K)=(D2U(LEN1,K)+DVC(LEN1,K))*RACS                      DIVRG1.28
          NUK=NUK+1                                                       DIVRG1.29
          NVCPK=NVCPK+1                                                   DIVRG1.30
          NVCK=NVCK+1                                                     DIVRG1.31
        ENDDO                                                             DIVRG1.32
      ELSE                                                                DIVRG1.33
        NUK=NJ+NU                                                         DIVRG1.34
        NVCMK=NJM1+NVC                                                    DIVRG1.35
        NVCK=NJ+NVC                                                       DIVRG1.36
        DO K=1,KMAX                                                       DIVRG1.37
          DO I=2,LEN1-1                                                   DIVRG1.38
            D2U(I,K)=(F(I+1,NUK)-F(I-1,NUK))*C(10)*3./2.                  DIVRG1.39
            DVC(I,K)=(F(I,NVCK)-F(I,NVCMK))*C(12)*3./2.                   DIVRG1.40
            S(I,K)=(D2U(I,K)+DVC(I,K))*RACS                               DIVRG1.41
          ENDDO                                                           DIVRG1.42
            D2U(1,K)=(F(2,NUK)-F(1,NUK))*C(10)*3./2.                      DIVRG1.43
            DVC(1,K)=(F(1,NVCK)-F(1,NVCMK))*C(12)*3./2.                   DIVRG1.44
            S(1,K)=(D2U(1,K)+DVC(1,K))*RACS                               DIVRG1.45 
            D2U(LEN1,K)=(F(LEN1,NUK)-F(LEN1-1,NUK))*C(10)*3./2.           DIVRG1.46
            DVC(LEN1,K)=(F(LEN1,NVCK)-F(LEN1,NVCMK))*C(12)*3./2.          DIVRG1.47
            S(LEN1,K)=(D2U(LEN1,K)+DVC(LEN1,K))*RACS                      DIVRG1.48
          NUK=NUK+1                                                       DIVRG1.49
          NVCK=NVCK+1                                                     DIVRG1.50
          NVCMK=NVCMK+1                                                   DIVRG1.51
        ENDDO                                                             DIVRG1.52
      ENDIF                                                               DIVRG1.53
      RETURN                                                              DIVRG1.54
      END                                                                 DIVRG1.55
C                                                                         DIVRG1.56
*DK DLDP                                                                    DLDP.1
      SUBROUTINE N2DLDP(NX,XL,XP,LEN)                                       DLDP.2
      INCLUDE 'n2param.h'                                                   DLDP.3
      include 'n2array.h'                                                   DLDP.4
      include 'buffe.h'                                                     DLDP.5
      include 'n2const.h'                                                   DLDP.6
      DIMENSION XL(IMAX,KMXP),XP(IMAX,KMXP)                                 DLDP.7
C     ****                                                                  DLDP.8
C     ****                   COMPUTE LONGITUDINAL DERIVATIVE                DLDP.9
C     ****                                                                  DLDP.10
      NXK=NJ+NX                                                             DLDP.11
      DO K=1,KMAXP1                                                         DLDP.12
        DO I=3,LEN-2                                                        DLDP.13
          XL(I,K)=C(10)*(F(I+1,NXK)-F(I-1,NXK))-C(11)*(F(I+2,NXK)           DLDP.14
     &            -F(I-2,NXK))                                              DLDP.15
         ENDDO                                                              DLDP.16
          XL(2,K)=C(10)*(F(3,NXK)-F(1,NXK))*3./4.                           DLDP.17
          XL(LEN1-1,K)=C(10)*(F(LEN1,NXK)-F(LEN1-2,NXK))*3./4.              DLDP.18
         NXK=NXK+1                                                          DLDP.19
      ENDDO                                                                 DLDP.20
C     ****                                                                  DLDP.21 
C     ****                   COMPUTE LATITUDINAL DERIVATIVE                 DLDP.22
C     ****                                                                  DLDP.23
      NXJP2K=NJP2+NX                                                        DLDP.24
      NXJP1K=NJP1+NX                                                        DLDP.25
      NXJM1K=NJM1+NX                                                        DLDP.26
      NXJM2K=NJM2+NX                                                        DLDP.27
      DO K=1,KMAXP1                                                         DLDP.28
        DO I=1,LEN                                                          DLDP.29
          XP(I,K)=C(12)*(F(I,NXJP1K)-F(I,NXJM1K))-                          DLDP.30   
     1            C(13)*(F(I,NXJP2K)-F(I,NXJM2K))                           DLDP.31   
        ENDDO                                                               DLDP.32
        NXJP2K=NXJP2K+1                                                     DLDP.33
        NXJP1K=NXJP1K+1                                                     DLDP.34
        NXJM1K=NXJM1K+1                                                     DLDP.35
        NXJM2K=NXJM2K+1                                                     DLDP.36
      ENDDO                                                                 DLDP.37 
      RETURN                                                                DLDP.38
      END                                                                   DLDP.39
C                                                                           DLDP.40
*DK DLDP1                                                                  DLDP1.1
      SUBROUTINE N2DLDP1(NX,XL,XP,LEN)                                     DLDP1.2
      include 'n2param.h'                                                  DLDP1.3
      include 'n2array.h'                                                  DLDP1.4
      include 'buffe.h'                                                    DLDP1.5
      include 'n2const.h'                                                  DLDP1.6
      DIMENSION XL(IMX,KMXP),XP(IMX,KMXP)                                  DLDP1.7
      CON1=0.5/C(1)                                                        DLDP1.8
      CON2=0.5/C(2)                                                        DLDP1.9
C     ****                                                                 DLDP1.10
C     ****                   COMPUTE LONGITUDINAL DERIVATIVE               DLDP1.11
C     ****                                                                 DLDP1.12
      NXK=NJ+NX                                                            DLDP1.13
      DO K=1,KMAXP1                                                        DLDP1.14  
        DO I=2,LEN1-1                                                      DLDP1.15
          XL(I,K)=CON1*(F(I+1,NXK)-F(I-1,NXK))                             DLDP1.16
        ENDDO                                                              DLDP1.17
        NXK=NXK+1                                                          DLDP1.18
      ENDDO                                                                DLDP1.19
C     ****                                                                 DLDP1.20
C     ****                   COMPUTE LATITUDINAL DERIVATIVE                DLDP1.21
C     ****                                                                 DLDP1.22
      NXJP1K=NJP1+NX                                                       DLDP1.23
      NXJM1K=NJM1+NX                                                       DLDP1.24
      DO K=1,KMAXP1                                                        DLDP1.25  
        DO I=2,LEN1-1                                                      DLDP1.26  
         XP(I,K)=CON2*(F(I,NXJP1K)-F(I,NXJM1K))                            DLDP1.27
        ENDDO                                                              DLDP1.28
        NXJP1K=NXJP1K+1                                                    DLDP1.29
        NXJM1K=NXJM1K+1                                                    DLDP1.30
      ENDDO                                                                DLDP1.31
      RETURN                                                               DLDP1.32
      END                                                                  DLDP1.33
C                                                                          DLDP1.34
*DK DTUV                                                                      DT.1
      SUBROUTINE N2DT(LEVEL,NTIME,NTER)                                       DT.2
C     ****                                                                    DT.3
C     ****     ADVANCES T,U AND V IN TIME                                     DT.4
C     ****                                                                    DT.5
      INCLUDE 'n2param.h'                                                     DT.6
      INCLUDE 'n2array.h'                                                     DT.6
      INCLUDE 'n2cvscr.h'                                                     DT.7
      INCLUDE 'n2const.h'                                                     DT.8
      INCLUDE 'index.h'                                                       DT.9
      INCLUDE 'buffe.h'                                                       DT.10
      INCLUDE 'n2phycs.h'                                                     DT.11
      INCLUDE 'start.h'                                                       DT.12
      INCLUDE 'n2rates.h'                                                     DT.13
      REAL*8 NOB                                                          NEWTON.13
      COMMON/N2RUNT/TTBOUND,NOB(JMX),AVTO,HOR(JMX)                            DT.8
      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
      IF(J.NE.2.AND.J.NE.JMAX-1)THEN                                        DTUV.36
       CALL N2ADVEC(NT,S1)                                                  DTUV.37
       CALL N2ADVEC2(NT,S1)                                                 DTUV.38
      ELSE                                                                  DTUV.39
       CALL N2ADVEC3(NT,S1)                                                 DTUV.40
      ENDIF                                                                 DTUV.41
C     ****                                                                  DTUV.42
C     ****     S1=ADVEC(T)+ADVECV(T)                                        DTUV.43
C     ****                                                                  DTUV.44
      CALL N2FILTER2(S1,J,KMAX,1)                                           DTUV.45
      CALL N2ADVECV(NT,S1,T1)                                               DTUV.46
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 K=1,KMAX
       IF(J.GT.2.AND.J.LT.JMAXM1)THEN	                                       
        DO I=1,LEN1                                                             DT.173
         S2(I,K)=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
       ELSE
        DO I=1,LEN1                                                             DT.173
         S2(I,K)=F(I,NTNMK)-C(26)*(-4.*(F(I,NTJP1K)+
     1           F(I,NTJM1K))+8.*F(I,NTNMK))                                   DT.175
        ENDDO                                                                   DT.176        
       ENDIF
       NTNMK=NTNMK+1                                                         DTUV.98
       NTJP2K=NTJP2K+1                                                       DTUV.99
       NTJP1K=NTJP1K+1                                                       DTUV.100
       NTJM1K=NTJM1K+1                                                       DTUV.101
       NTJM2K=NTJM2K+1                                                       DTUV.102
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,LEN1-2                                                           DT.181
        S3(I,K)=S2(I,K)-C(26)*(S2(I+2,K)+S2(I-2,K)-4.*(S2(I+1,K)+              DT.182
     1          S2(I-1,K))+6.*S2(I,K))                                         DT.183
       ENDDO                                                                   DT.184
       S3(2,K)=S2(2,K)-C(26)*(-4.*(S2(3,K)                                   DTUV.107
     A         +S2(1,K))+8.*S2(2,K))                                         DTUV.108
       S3(LEN1-1,K)=S2(LEN1-1,K)-C(26)*(-4.*(S2(LEN1,K)                      DTUV.109
     A              +S2(LEN1-2,K))+8.*S2(LEN1-1,K))                          DTUV.110
      ENDDO
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
c       if(j.eq.34)write(6,*)F(I,NCPK),S1(I,K),S3(I,K),i,k
        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
c       if(j.eq.32)write(6,*)F(I,NPS1K),F(I,NPS2K),i,k
       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
c       if(j.eq.32)write(6,*)S5(I,1),F(I,NQDHK),i
       S5(I,1)=S5(I,1)+F(I,NQDHK)                                             DT.220
      ENDDO                                                                   DT.222
c      pause
      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
c        if(j.eq.2) write(6,*)S5(I,K),S8(I,K),F(I,NPS2K),F(I,NTK),i,k
        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      if(j.eq.2)pause
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
c       if(j.eq.10)write(6,*)S2(I,1),S3(I,1),F(I,NLXXK),F(I,NLYYK),
c     1                      F(I,NLXYK),F(I,NLYXK),i
       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
c       S5(I,1)=S5(I,1)                     !!!!!!!!!temporal test
       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,IMAX                                                            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,IMAX                                                             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,IMAX                                                            DT.365
c        if(j.eq.2)write(6,*)S8(I,K),F(I,NKMK),F(I,NTK),S10(I,K),
c     1            S11(I,K),i,k
        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
c      if(j.eq.10.and.mod(i-1,3).eq.0)
c     1 write(6,*)S1(I,K),S5(I,K),i
        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
c      if(j.eq.4)then
c      do i=1,len1,3
c       write(6,*)S2(I,1),S3(I,1),i
c      enddo
c      pause
c      endif
      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
c       if(j.eq.10.and.mod(i-1,3).eq.0)
c     1 write(6,*)S12(I,1),F(I,NWTEK),i
       S12(I,1)=S12(I,1)+F(I,NWTEK)                                           DT.488
      ENDDO                                                                   DT.489
c      pause
      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
c       if(j.eq.10.and.mod(i-1,3).eq.0)
c     1 write(6,*)S10(I,K),S13(I,K),i,k
        S10(I,K)=S10(I,K)-EXPS(K)*S13(I,K)                                    DT.495
       ENDDO                                                                  DT.496
      ENDDO                                                                   DT.497
c       if(j.eq.10)pause
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
c       if(j.eq.4)write(6,*)S12(I,1),S9(I,1),T1(I),i
       S12(I,1)=S12(I,1)-2.*S9(I,1)*T1(I)                                     DT.509
       S9(I,1)=0.                                                             DT.510
      ENDDO                                                                   DT.511
c       if(j.eq.4)pause
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
      NTNPK=NJNP+NT                                                           DT.519
c        if(j.eq.10)then
c      do k=1,kmax
c       do i=1,len1,3
c        write(6,*)S9(i,k),S10(i,k),S11(i,k),S12(i,k),i,k
c       enddo
c      enddo
c        pause
c        endif
      CALL TRSOLV(S9,S10,S11,S12,S15,F(1,NTNPK),LEN1,2,LEN1-1,KMAXP1,         DT.520
     1            1,KMAX,1)                                                   DT.521
C     ****                                                                  DTUV.
C     ****     BOUNDARY VALUES FROM GENERAL CIRCULATION MODEL               DTUV.
C     ****                                                                  DTUV.   
      CALL N2NESTBOUN(J,NT,LEVEL,NTIME)                                       DTUV.
C     ****                                                                    DT.530
C     ****     Time smoothing of T                                            DT.531
C     ****                                                                    DT.532
      CALL N2SHAPIRO2(NT,KMAX)
      NTNMK=NJ+NTNM                                                         DTUV.836
      NTK=NJ+NT                                                             DTUV.837
      NTNPK=NJNP+NT                                                         DTUV.838
      NTNMNK=NJNP+NTNM                                                      DTUV.839
      DO K=1,KMAX                                                           DTUV.840
        DO I=1,LEN1                                                         DTUV.841
c         write(6,*)F(I,NTNMK),F(I,NTNPK),i,k
         S1(I,K)=(F(I,NTNMK)+F(I,NTNPK))*C(31)                              DTUV.842
         F(I,NTNMNK)=F(I,NTK)*C(30)+S1(I,K)                                 DTUV.843
        ENDDO                                                               DTUV.844
        NTNMK=NTNMK+1                                                       DTUV.845
        NTK=NTK+1                                                           DTUV.846
        NTNPK=NTNPK+1                                                       DTUV.847
        NTNMNK=NTNMNK+1                                                     DTUV.848
      ENDDO                                                                 DTUV.849
c      pause
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,IMAX                                                             DT.547
       F(I,NTNPK)=T1(I)                                                       DT.548
      ENDDO                                                                   DT.549
      NTNPK=NJNP+NT
      tem=0.
      do k=1,kmax
	do 2020 i=2,len1-1
	if(tem.LE.F(I,NTNPK))then
	tem=F(I,NTNPK)
	met=i
	endif
c        if(j.eq.32)write(6,*)tem,F(I,NTNPK),i
2020	continue
       ntnpk=ntnpk+1
      enddo
        write(6,*)tem,j
998	format(d16.8,2i8)
      RETURN                                                                  DT.563
      END                                                                     DT.564
C                                                                             DT.565
*DKDUV                                                                       DUV.1
      SUBROUTINE N2DUV(LEVEL,NTIME,NTER)                                     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 "n2param.h"                                                    DUV.9
      INCLUDE "n2array.h"                                                    DUV.9
      INCLUDE "buffe.h"                                                      DUV.10
      INCLUDE "n2const.h"                                                    DUV.11
      INCLUDE "index.h"                                                      DUV.12
      INCLUDE "n2phycs.h"                                                    DUV.13
      INCLUDE "start.h"                                                      DUV.14
      INCLUDE "n2cvscr.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,IMX,KMXP), QQ(2,2,IMX,KMXP),                          DUV.22
     1 RR(2,2,IMX,KMXP), SS(2,IMX,KMXP), BETA(2,2,IMX,KMXP),                 DUV.23
     2 GAMMA(2,2,IMX,KMXP), YY(2,IMX,KMXP), XX(2,IMX,KMXP)                   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(JMX)                                                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
      IF(J.NE.2.AND.J.NE.JMAX-1)THEN                                        DTUV.491 
        CALL N2ADVEC(NU,S1)                                                 DTUV.492
        CALL N2ADVEC2(NU,S1)                                                DTUV.493
      ELSE                                                                  DTUV.494
        CALL N2ADVEC3(NU,S1)                                                DTUV.495
      ENDIF                                                                 DTUV.496
C     ****                                                                   DUV.276
C     ****     Similarly for v in S2                                         DUV.277
C     ****                                                                   DUV.278
      IF(J.NE.2.AND.J.NE.JMAX-1)THEN                                        DTUV.500
        CALL N2ADVEC(NV,S2)                                                 DTUV.501
        CALL N2ADVEC2(NV,S2)                                                DTUV.502
      ELSE                                                                  DTUV.503
        CALL N2ADVEC3(NV,S2)                                                DTUV.504
      ENDIF                                                                 DTUV.505
      CALL N2FILTER2(S1,J,KMAX,LEVEL)
      CALL N2FILTER2(S2,J,KMAX,LEVEL)
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 N2GLP(S14,S15,NTER)                                                      DUV.291
      CALL N2FILTER2(S14,J,KMAX,LEVEL)
      CALL N2FILTER2(S15,J,KMAX,LEVEL)
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
c      if(j.eq.32)write(6,*)S1(I,1),S2(I,1),S14(I,1),S15(I,1),F(I,NFLHK),
c     1 F(I,NFPHK),i
       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       if(j.eq.32)pause
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 K=1,KMAX                                                           DTUV.562 
       IF(J.EQ.2.OR.J.EQ.JMAXM1)THEN                                        DTUV.563     
          DO I=1,LEN1                                                       DTUV.564
            S6(I,K)=F(I,NUNMK)-C(26)*(-4.*(F(I,NUJP1K)                      DTUV.565
     A              +F(I,NUJM1K))+8.*F(I,NUNMK))                            DTUV.566
          ENDDO                                                             DTUV.567
       ELSE                                                                 DTUV.568
        DO I=1,LEN1                                                         DTUV.569
         S6(I,K)=F(I,NUNMK)-C(26)*(F(I,NUJP2K)+F(I,NUJM2K)-4.*              DTUV.570
     A           (F(I,NUJP1K)+F(I,NUJM1K))+6.*F(I,NUNMK))                   DTUV.571
        ENDDO                                                               DTUV.572
       ENDIF	                                                            DTUV.573
       NUJP2K=NUJP2K+1                                                      DTUV.574
       NUJP1K=NUJP1K+1                                                      DTUV.575
       NUNMK=NUNMK+1                                                        DTUV.576
       NUJM1K=NUJM1K+1                                                      DTUV.577
       NUJM2K=NUJM2K+1                                                      DTUV.578
      ENDDO
C     ****                                                                   DUV.321
C     ****      Now longitudinal smoothing for u with results to S7          DUV.322
C     ****                                                                   DUV.323
      DO K=1,KMAX                                                           DTUV.580
       DO I=3,LEN1-2                                                        DTUV.581
        S7(I,K)=S6(I,K)-C(26)*(S6(I+2,K)+S6(I-2,K)-4.*                       DUV.325
     1          (S6(I+1,K)+S6(I-1,K))+6.*S6(I,K))                            DUV.326
       ENDDO
       S7(2,K)=S6(2,K)-C(26)*(-4.*(S6(3,K)+                                 DTUV.585
     A         S6(1,K))+8.*S6(2,K))                                        DTUV.586
       S7(LEN1-1,K)=S6(LEN1-1,K)-C(26)*(-4.*(S6(LEN1,K)+                    DTUV.587
     A              S6(LEN1-2,K))+8.*S6(LEN1-1,K))                         DTUV.588
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
       DO I=2,LEN1-1                                                        DTUV.589
c       if(j.eq.2)write(6,*)S1(I,K),S7(I,K),i,k
        S1(I,K)=S1(I,K)-C(7)*S7(I,K)                                         DUV.333
       ENDDO                                                                 DUV.334
      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 K=1,KMAX                                                           DTUV.601
       IF(J.EQ.2.OR.J.EQ.JMAXM1)THEN                                        DTUV.602
        DO I=1,LEN1                                                         DTUV.603
         S6(I,K)=F(I,NVNMK)-C(26)*(-4.*(F(I,NVJP1K)                         DTUV.604
     A           +F(I,NVJM1K))+8.*F(I,NVNMK))                               DTUV.605
        ENDDO                                                                DUV.348
       ELSE                                                                 DTUV.607
        DO I=1,LEN1                                                         DTUV.608
         S6(I,K)=F(I,NVNMK)-C(26)*(F(I,NVJP2K)+F(I,NVJM2K)-4.*              DTUV.609
     A           (F(I,NVJP1K)+F(I,NVJM1K))+6.*F(I,NVNMK))                   DTUV.610
        ENDDO                                                               DTUV.611
       ENDIF	                                                            DTUV.612
       NVJP2K=NVJP2K+1                                                      DTUV.613
       NVJP1K=NVJP1K+1                                                      DTUV.614
       NVNMK=NVNMK+1                                                        DTUV.615
       NVJM1K=NVJM1K+1                                                      DTUV.616
       NVJM2K=NVJM2K+1                                                      DTUV.617
      ENDDO                                                                 DTUV.618
C     ****                                                                   DUV.349
C     ****      Now longitudinal smoothing for v with results to S7          DUV.350
C     ****                                                                   DUV.351
      DO K=1,KMAX                                                           DTUV.619
       DO I=3,LEN1-2                                                         DUV.352
        S7(I,K)=S6(I,K)-C(26)*(S6(I+2,K)+S6(I-2,K)-4.*                       DUV.353
     1         (S6(I+1,K)+S6(I-1,K))+6.*S6(I,K))                             DUV.354
       ENDDO                                                                DTUV.623
       S7(2,K)=S6(2,K)-C(26)*(-4.*(S6(3,K)+                                 DTUV.624
     A         S6(1,K))+8.*S6(2,K))                                        DTUV.625
       S7(LEN1-1,K)=S6(LEN1-1,K)-C(26)*(-4.*(S6(LEN1,K)+                    DTUV.626
     A              S6(LEN1-2,K))+8.*S6(LEN1-1,K))                         DTUV.627
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
       DO I=2,LEN1-1                                                        DTUV.628
        S2(I,K)=S2(I,K)-C(7)*S7(I,K)                                         DUV.361
       ENDDO                                                                 DUV.362
      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
c       if(j.eq.34)write(6,*)SS(1,I,K),S1(I,K),F(I,NUIK),F(I,NVIK),i,k
       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
c        write(6,*)QQ(1,1,I,K),QQ(1,2,I,K),QQ(2,1,I,K),QQ(2,2,I,K),i,k
       ENDDO                                                                 DUV.529
      ENDDO                                                                  DUV.530
c      pause
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
c       if(j.eq.2)write(6,*)SS(1,I,1),PP(1,1,I,1),T1(I),PP(1,2,I,1),
c     1 T2(I),i
       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
c       if(j.eq.2)write(6,*)ss(1,I,1),ss(2,I,1),1
c     1QQ(2,2,I,1),i
      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,2,IMAX-1,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=2,IMAX-1                                                         DUV.585
        F(I,NUK)=XX(1,I,K)                                                   DUV.586
        F(I,NVK)=XX(2,I,K)                                                   DUV.587
c        if(j.eq.2)write(6,*)F(I,NUK),F(I,NVK),i,k
       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=2,IMAX-1                                                          DUV.596
       F(I,NUK)=T1(I)                                                        DUV.597
       F(I,NVK)=T2(I)                                                        DUV.598
      ENDDO                                                                  DUV.599
C     ****                                                                  DTUV.  
C     ****     BOUNDARY VALUES FROM GENERAL CIRCULATION MODEL               DTUV. 
C     ****                                                                  DTUV.
      CALL N2NESTBOUN(J,NU,LEVEL,NTIME)                                       DTUC.
      CALL N2NESTBOUN(J,NV,LEVEL,NTIME)                                       DTUC.
C     ****                                                                   DUV.600
C     ****     Fourier smoothing of u and v                                  DUV.601
C     ****                                                                   DUV.602
c      IF(KUT(J).LT.IMAXH)THEN                                                DUV.603
c       NUNPK=NJNP+NU                                                         DUV.604
c       NVNPK=NJNP+NV                                                         DUV.605
c       CALL FILTER(NUNPK,KMAX,KUT(J))                                        DUV.606
c       CALL FILTER(NVNPK,KMAX,KUT(J))                                        DUV.607
c      ENDIF                                                                  DUV.608
C     ****     TIME SMOOTHING OF T,U AND V                                  DTUV.832
C     ****     S1=(TNM+TNP)*(.5*(1.-ALPHA))                                 DTUV.833
C     ****     T(SMOOTH)=(T*ALPHA)+S1                                       DTUV.834
C     ****                                                                  DTUV.835
      CALL N2SHAPIRO2(NU,KMAX)
      CALL N2SHAPIRO2(NV,KMAX)
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
c      umax=0.
c      vmax=0.
      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
      umax=0.
      vmax=0.
      uimax=0.
      vimax=0.
      nuik=nui
      nvik=nvi
      do k=1,kmax
       do i=10,len1-9
        if(umax.le.dabs(F(I,NUNPK)))umax=dabs(F(I,NUNPK))
        if(vmax.le.dabs(F(I,NvNPK)))vmax=dabs(F(I,NvNPK))   
        if(uimax.le.dabs(F(I,NUiK)))uimax=dabs(F(I,NUiK))
        if(vimax.le.dabs(F(I,NviK)))vimax=dabs(F(I,NviK)) 
       enddo
       NUNPK=NUNPK+1
       NvNPK=NvNPK+1
       nuik=nuik+1
       nvik=nvik+1
      enddo
c      write(6,*)umax,vmax,uimax,vimax
c      pause
      RETURN                                                                 DUV.645
      END                                                                    DUV.646
C                                                                            DUV.647
*DK DUMINTER                                                            DUMINTER.1
      SUBROUTINE N2DUMINTER(W,J1,JM,LEVEL)                              DUMINTER.2
C     ****                                                              DUMINTER.3
C     ****     INTERPOLATION OF FIELDS OF MAGNETIC FIELD                DUMINTER.4
C     ****     FOR NESTED GRIDS                                         DUMINTER.5
C     ****                                                              DUMINTER.6
      INCLUDE 'n1param.h'                                               DUMINTER.7
      INCLUDE 'n1const.h'                                               DUMINTER.8
      INCLUDE 'nestcnt.h'                                               DUMINTER.9
      INCLUDE 'n2nestg.h'                                               DUMINTER.10
      COMMON/N1TRGM/RLATM(IMX,JMX),RLONM(IMX,JMX),DIPMAG(IMX,JMX),      DUMINTER.11
     1              DECMAG(IMX,JMX),SNDEC(IMX,JMX),CSDEC(IMX,JMX),      DUMINTER.12
     2              SN2DEC(IMX,JMX),SNCSDC(IMX,JMX),DUMDUM(JMX,3)       DUMINTER.13
      DIMENSION W(J1:JM,3)                                              DUMINTER.14
      RATIO=NESTRI(LEVEL)                                               DUMINTER.15
      DO K=1,3                                                          DUMINTER.16
       DO J=1,JNX                                                       DUMINTER.17
        IF(J.EQ.1)THEN                                                  DUMINTER.18
         JJ=NESTJ1(LEVEL)+J-1                                           DUMINTER.19
         W(J,K)=DUMDUM(JJ,K)                                            DUMINTER.20
        ELSE                                                            DUMINTER.21
         J2=NESTRI(LEVEL)*(J-1)+1                                       DUMINTER.22
         J1=NESTRI(LEVEL)*(J-2)+1                                       DUMINTER.23
         JJ=NESTJ1(LEVEL)+J-1                                           DUMINTER.24
         W(J2,K)=DUMDUM(JJ,K)                                           DUMINTER.25
         DO L=1,NESTRI(LEVEL)-1                                         DUMINTER.26
          W(J2-L,K)=W(J2,K)-DBLE(L)*(W(J2,K)-W(J1,K))/RATIO             DUMINTER.27
         ENDDO                                                          DUMINTER.28
        ENDIF                                                           DUMINTER.29
       ENDDO                                                            DUMINTER.30
      ENDDO                                                             DUMINTER.31
      RETURN                                                            DUMINTER.32
      END                                                               DUMINTER.33
C                                                                       DUMINTER.34
*DK ELDEN                                                                  ELDEN.1
      SUBROUTINE N2ELDEN                                                   ELDEN.2
C     ****                                                                 ELDEN.3
C     ****     CALCULATES ELECTRON DENSITY AND ION NUMBER DENSITIES        ELDEN.4
C     ****                                                                 ELDEN.5
      INCLUDE 'n2param.h'                                                  ELDEN.6
      INCLUDE 'n2array.h'                                                  ELDEN.6
      INCLUDE 'n2cvscr.h'                                                  ELDEN.7
      INCLUDE 'n2const.h'                                                  ELDEN.8
      INCLUDE 'index.h'                                                    ELDEN.9
      INCLUDE 'buffe.h'                                                    ELDEN.10
      INCLUDE 'n2rates.h'                                                  ELDEN.11
      include 'n2phycs.h'
      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 FDBK
      SUBROUTINE N2FDBK(LEVEL)
C     ****                                                                  FLOW.4
C     ****     AVERAGE NESTED GRID VALUES TO COARSE GRID TO COMPLETE          FLOW.5
C     ****     TWO-WAY INTERACTION                                           FLOW.6
C     ****                                                                  FLOW.7
      INCLUDE 'n1param.h'
      INCLUDE 'n1array.h'
      INCLUDE 'n1const.h'
      INCLUDE 'nestcnt.h'                                                   ADVNCE.12
      INCLUDE 'n2nestg.h'
      DIMENSION S(INX,NVR,JNX)
C     ****                                                                  FLOW.4
C     ****     AVERAGE NESTED GRID VALUES FOR TWO-WAY INTERACTION            FLOW.6
C     **** 
      CALL N2TWOWAY(S,LEVEL)
C     ****                                                                  FLOW.4
C     ****     UPDATE COARSE GRID VALUES IN THE NESTED GRID DOMAIN            FLOW.6
C     ****       
      NVRK=NVR
      DO K=1,NVRK
       DO JJ=3,JNX-2
        JC=NESTJ1(LEVEL)+JJ-1
        DO II=3,INX-2
         IC=NESTI1(LEVEL)+II-1
         G(IC,K,JC)=S(II,K,JJ)
        ENDDO
       ENDDO
      ENDDO
      write(6,*)'twoway'
      RETURN
      END
*DK FLOW                                                                    FLOW.1
      SUBROUTINE N2FLOWION(DCUSP,DALFA,DALFA2,DFLUX,DFLUX2,DDRIZL)          FLOW.2
C     ****                                                                  FLOW.4
C     ****     COMPUTE ELECTRIC FIELD COMPONENTS BY SPACE CENTERED          FLOW.5
C     ****     TECHNIQUE(VOLTS/M)                                           FLOW.6
C     ****                                                                  FLOW.7
      INCLUDE 'n2param.h'                                                   FLOW.8
      INCLUDE 'n2const.h'                                                   FLOW.9
      INCLUDE 'n2phycs.h'                                                   FLOW.10
      COMMON/N2TRGM/RLATM(IMX,JMX),RLONM(IMX,JMX),                          FLOW.11
     1      DIPMAG(IMX,JMX),DECMAG(IMX,JMX),SNDEC(IMX,JMX),                 FLOW.12
     2      CSDEC(IMX,JMX),SN2DEC(IMX,JMX),SNCSDC(IMX,JMX),                 FLOW.13
     3      RLATMP(JMX),RLONMP(JMX),DLONS(JMX)                              FLOW.14
      DIMENSION DCUSP(IMX),DALFA(IMX),DFLUX(IMX),DDRIZL(IMX),               FLOW.15
     1          DALFA2(IMX),DFLUX2(IMX),DLAT(IMX),DLON(IMX)                 FLOW.16
      COMMON/N2TRGM1/RLATMR(IMX,JMX),RLONMR(IMX,JMX)
      COMMON/SUNANGLE/DLONSUN
C     ****                                                                  FLOW.17
C     ****     SET UP DIPOLE COORDINATES                                    FLOW.18
C     ****                                                                  FLOW.19
      DO I=1,IMAX                                                           FLOW.20
       DLAT(I)=RLATMR(I,J)                                                  FLOW.21
       DLON(I)=RLONMR(I,J)-DLONSUN                                          FLOW.22
      ENDDO                                                                 FLOW.23
C     ****                                                                  FLOW.24
C     ****     COMPUTE POTENTIAL                                            FLOW.25
C     ****                                                                  FLOW.26
      CALL N2FLOWV3(DLAT,DLON)                                              FLOW.27
      CALL N2POLHT(DCUSP,IMAX)                                              FLOW.28
      CALL N2AURHT(DLAT,DLON,DALFA,DFLUX,DDRIZL,DALFA2,DFLUX2,IMAX)         FLOW.29
      RETURN                                                                FLOW.30
      END                                                                   FLOW.31
C                                                                           FLOW.32
*DK FLOWV3                                                                FLOWV3.1
      SUBROUTINE N2FLOWV3(DLAT,DLON)                                      FLOWV3.2
C     ****                                                                FLOWV3.3
C     ****     COMPUTE ELECTRIC POTENTIAL                                 FLOWV3.4
C     ****                                                                FLOWV3.5
      INCLUDE 'n2param.h'                                                 FLOWV3.6
      INCLUDE 'n2const.h'                                                 FLOWV3.7
      include 'n2phycs.h'
      PARAMETER (IMX0=81)
      DIMENSION DLAT(IMX),DLON(IMX)                                       FLOWV3.8
      COMMON /IONCR/ ISTAR,IHEM,THETA0(2),OFFA(2),OFFC(2),DSKOFA(2),      FLOWV3.9
     |DSKOFC(2),PHID(2),PHIN(2),PHIDP0(2),PHIDM0(2),PHINP0(2),PHINM0(2),  FLOWV3.10
     2 PSIM(2),PSIE(2),PCEN(2),R1(2),COLATC(IMAXMP,JMX0),
     3 P(IMX0,JMX0),CRIT(2)                                               FLOWV3.11
      COMMON /OVALPOS/ COSOFA(2),SINOFA(2),ASLONA(2),PI,PI2               FLOWV3.12
      COMMON/N2ANGLE/ALON(IMX),COLAT(IMX)                                 FLOWV3.13
      DIMENSION SINLAT(IMX),COSLAT(IMX),SINLON(IMX),COSLON(IMX)           FLOWV3.14
      DATA E/1.D-6/                                                       FLOWV3.16
C     ****                                                                FLOWV3.16
C     ****     CONVERT PARAMETERS TO RADIANS ETC.                         FLOWV3.17
C     ****                                                                FLOWV3.18
      IF(ISTAR.EQ.0)THEN                                                  FLOWV3.19
       ISTAR=1                                                            FLOWV3.20
       PI=4.*DATAN(1.D0)                                                  FLOWV3.21
       PI2=2.*PI                                                          FLOWV3.22
       PIH=.5*PI                                                          FLOWV3.23
       DO N=1,2                                                           FLOWV3.24
        IF(ABS(OFFA(N)+DSKOFA(N)).GT.0.01)THEN                            FLOWV3.25
         OFDA=DSQRT(OFFA(N)**2+DSKOFA(N)**2)                              FLOWV3.26
         COSOFA(N)=DCOS(OFDA)                                             FLOWV3.27
         SINOFA(N)=DSIN(OFDA)                                             FLOWV3.28
         ASLONA(N)=DASIN(DSKOFA(N)/OFDA)                                  FLOWV3.29
        ELSE                                                              FLOWV3.30
         OFDA=0.                                                          FLOWV3.31
         COSOFA(N)=1.                                                     FLOWV3.32
         SINOFA(N)=0.                                                     FLOWV3.33
         ASLONA(N)=0.                                                     FLOWV3.34
        ENDIF                                                             FLOWV3.35
       ENDDO                                                              FLOWV3.36
      ENDIF                                                               FLOWV3.37
C     ****                                                                FLOWV3.38
C     ****               SET IHEM = 1,2  FOR  S,N HEMISPHERE              FLOWV3.39
C     ****                                                                FLOWV3.40
      IMAXD2=MAX0(1,IMAX/2)                                               FLOWV3.41
      IHEM=IDINT(DLAT(IMAXD2)*2./3.1416+2.)                               FLOWV3.42
C     ****                                                                FLOWV3.43
C     ****     TRANSFORM TO AURORAL CIRCLE CORDINATES                     FLOWV3.44
C     ****     I. E. CALCULATE COLAT AND ALON FOR POLHT AND AURHT         FLOWV3.45
C     ****                                                                FLOWV3.46
      DO I=1,IMAX                                                         FLOWV3.47
       SINLAT(I)=DSIN(DABS(DLAT(I)))                                      FLOWV3.48
       COSLAT(I)=DCOS(DLAT(I))                                            FLOWV3.49
       SINLON(I)=DSIN(DLON(I)+ASLONA(IHEM))                               FLOWV3.50
       COSLON(I)=DCOS(DLON(I)+ASLONA(IHEM))                               FLOWV3.51
       COLAT(I)=COSOFA(IHEM)*SINLAT(I)-SINOFA(IHEM)*COSLAT(I)*            FLOWV3.52
     1            COSLON(I)                                               FLOWV3.53
       COLAT(I)=DACOS(COLAT(I))                                           FLOWV3.54
       ALON(I)=DMOD(DATAN2(+SINLON(I)*COSLAT(I),SINLAT(I)*SINOFA(IHEM)+   FLOWV3.55
     1         COSOFA(IHEM)*COSLAT(I)*COSLON(I))-ASLONA(IHEM)+            FLOWV3.56
     2         3.*PI,PI2)-PI                                              FLOWV3.57
      ENDDO                                                               FLOWV3.58
      RETURN                                                              FLOWV3.59
      END                                                                 FLOWV3.60
C                                                                         FLOWV3.61
* DK GLP                                                                     GLP.1
      SUBROUTINE N2GLP(ZL,ZP,NTER)                                           GLP.2
      include 'n2param.h'                                                    GLP.3
      include 'n2array.h'                                                    GLP.4
      include 'n2cvscr.h'                                                    GLP.5
      include 'n2const.h'                                                    GLP.6
      include 'index.h'                                                      GLP.7
      include 'n2phycs.h'                                                    GLP.8
      include 'buffe.h'                                                      GLP.9
      include 'start.h'                                                      GLP.10
      include 'nestcnt.h'                                                    GLP.11
      DIMENSION ZL(IMX,KMXP),ZP(IMX,KMXP)                                    GLP.12
      COMPLEX*16 EXPT                                                        GLP.13
      DATA WT/0.225/                                                         GLP.14
C     ****                                                                   GLP.15
C     ****     S6=TN+WT*(TNM-2.*TN+TNP)=TBAR                                 GLP.16
C     ****     S7(K)=(MS(K)+MS(K+1))*.5=MBAR                                 GLP.17
      NMSK=NJ+NMS                                                            GLP.18
      NTK=NJ+NT                                                              GLP.19
      NTNMK=NJ+NTNM                                                          GLP.20
      NTNPK=NJNP+NT                                                          GLP.21
      DO K=1,KMAX                                                            GLP.22
        DO I=1,LEN1                                                          GLP.23
          S6(I,K)=(F(I,NTNPK)-2.*F(I,NTK)+F(I,NTNMK))*WT+F(I,NTK)            GLP.24
          S7(I,K)=(F(I,NMSK)+F(I,NMSK+1))*.5                                 GLP.25
        ENDDO                                                                GLP.26
        NMSK=NMSK+1                                                          GLP.27
        NTK=NTK+1                                                            GLP.28
        NTNMK=NTNMK+1                                                        GLP.29
        NTNPK=NTNPK+1                                                        GLP.30
      ENDDO                                                                  GLP.31
C     ****                                                                   GLP.39
C     ****     S7=(DS*R/G)*S6/S7=(C(3)/C(65))*(TBAR+T0)/M                    GLP.40
C     ****                                                                   GLP.41
      DO K=1,KMAX                                                            GLP.42
        DO I=1,LEN1                                                          GLP.43
          S7(I,K)=(C(3)/C(65))*S6(I,K)/S7(I,K)                               GLP.44
        ENDDO                                                                GLP.45
      ENDDO                                                                  GLP.46
C     ****                                                                   GLP.47
C     ****     STORE NZ TEMPORARILY                                          GLP.48
C     ****                                                                   GLP.49
      NZK=NJ+NZ                                                              GLP.50
      DO K=1,KMAXP1                                                          GLP.51
        DO I=1,LEN1                                                          GLP.52
          S6(I,K)=F(I,NZK)                                                   GLP.53
        ENDDO                                                                GLP.54
        NZK=NZK+1                                                            GLP.55
      ENDDO                                                                  GLP.56
      NZK=NJ+NZ                                                              GLP.57
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.65
C     ****     Z(K+1)=S7(K)+Z(K)                                             GLP.66
C     ****                                                                   GLP.67
      DO K=1,KMAX                                                            GLP.68
        DO I=1,LEN1                                                          GLP.69
          F(I,NZK+1)=S7(I,K)+F(I,NZK)                                        GLP.70
        ENDDO                                                                GLP.71
        NZK=NZK+1                                                            GLP.72
      ENDDO                                                                  GLP.73
      NZK=NZ                                                                 GLP.74
      IF(J.EQ.2.OR.J.EQ.JMAXM1)THEN                                          GLP.75
        CALL N2DLDP1(NZK,ZL,ZP,LEN1)                                         GLP.76
      ELSE                                                                   GLP.77
        CALL N2DLDP(NZK,ZL,ZP,LEN1)                                          GLP.78  
      ENDIF                                                                  GLP.81
C     ****                                                                   GLP.82
C     ****     RESTORE NZ                                                    GLP.83
C     ****                                                                   GLP.84
      NZK=NJ+NZ                                                              GLP.85
      DO K=1,KMAXP1                                                          GLP.86 
        DO I=2,LEN1-1                                                        GLP.87
          F(I,NZK)=S6(I,K)                                                   GLP.88
        ENDDO                                                                GLP.89
        NZK=NZK+1                                                            GLP.90
      ENDDO                                                                  GLP.91
      DO K=1,KMAX                                                            GLP.92
        DO I=2,LEN1-1                                                        GLP.93
          ZL(I,K)=(ZL(I,K)+ZL(I,K+1))*.5*C(54)*RACS                          GLP.94
          ZP(I,K)=(ZP(I,K)+ZP(I,K+1))*.5*C(54)*C(52)                         GLP.95
        ENDDO                                                                GLP.96
      ENDDO                                                                  GLP.97
      RETURN                                                                 GLP.98
      END                                                                    GLP.99
C                                                                            GLP.100
*DK HDIF                                                                    HDIF.1
      SUBROUTINE N2HDIF                                                     HDIF.2
      INCLUDE 'n2param.h'                                                   HDIF.3
      INCLUDE 'n2cvscr.h'                                                   HDIF.4
      INCLUDE 'n2array.h'                                                   HDIF.5
      INCLUDE 'buffe.h'                                                     HDIF.6
      INCLUDE 'n2const.h'                                                   HDIF.7
      INCLUDE 'index.h'                                                     HDIF.8
      INCLUDE 'n2phycs.h'                                                   HDIF.9
C     ****                                                                  HDIF.10
C     ****                   SAVE KMH VALUES OF LINE J IN S2                HDIF.11
C     ****                                                                  HDIF.12
      NKMHK=NKMH                                                            HDIF.13
      DO K=1,KMAX                                                           HDIF.14
       DO I=1,LEN1-1                                                        HDIF.15
        S2(I,K)=F(I,NKMHK)                                                  HDIF.16
       ENDDO                                                                HDIF.17
       NKMHK=NKMHK+1                                                        HDIF.18
      ENDDO                                                                 HDIF.19
C     ****                                                                  HDIF.20
C     ****     SAVE RH(J)=M/(T+T0) IN S4                                    HDIF.21
C     ****                                                                  HDIF.22
      NRHK=NRH                                                              HDIF.23
      DO I=1,LEN2                                                           HDIF.24
       S4(I,1)=F(I,NRHK)                                                    HDIF.25
      ENDDO                                                                 HDIF.26
C     ****                                                                  HDIF.27
C     ****                   READ U,V FOR J+1,J+2,AT N-1                    HDIF.28
C     ****                                                                  HDIF.29
      NUJP2=NJP2+NUNM                                                       HDIF.30
      NUJP1=NJP1+NUNM                                                       HDIF.31
      NVJP2=NJP2+NVNM                                                       HDIF.32
      NVJP1=NJP1+NVNM                                                       HDIF.33
C     ****                                                                  HDIF.34
C     ****                   CALC KMH = 2*K0*K0*SQRT(DS*DS+DT*DT)           HDIF.35
C     ****                                                                  HDIF.36
      ABCSJ=DABS(CS(J+1))                                                   HDIF.37
      ABCSJP=DABS(CS(J+2))                                                  HDIF.38
      CON1=C(52)*.5/C(1)                                                    HDIF.39
      CON2=C(52)/(C(2)*(ABCSJ+ABCSJP))                                      HDIF.40
      CON3=2.*C(109)*C(109)                                                 HDIF.41
      NKMHK=NKMH                                                            HDIF.42
      DO K=1,KMAX                                                           HDIF.43
       DO I=1,LEN1-1                                                        HDIF.44
        DT=CON1*((F(I+1,NUJP2)-F(I,NUJP2))/CS(J+2) +                        HDIF.45
     1     (F(I+1,NUJP1)-F(I,NUJP1))/CS(J+1)) -                             HDIF.46
     2     CON2*((F(I+1,NVJP2)+F(I,NVJP2))*ABCSJP -                         HDIF.47
     3     (F(I+1,NVJP1)+F(I,NVJP1))*ABCSJ)                                 HDIF.48
        DS=CON1*((F(I+1,NVJP2)-F(I,NVJP2))/CS(J+2) +                        HDIF.49
     1     (F(I+1,NVJP1)-F(I,NVJP1))/CS(J+1)) +                             HDIF.50
     2     CON2*((F(I+1,NUJP2)+F(I,NUJP2))*ABCSJP -                         HDIF.51
     3     (F(I+1,NUJP1)+F(I,NUJP1))*ABCSJ)                                 HDIF.52
        F(I,NKMHK)=CON3*DSQRT(DS*DS+DT*DT)                                  HDIF.53
       ENDDO                                                                HDIF.54
       NUJP2=NUJP2+1                                                        HDIF.55
       NUJP1=NUJP1+1                                                        HDIF.56
       NVJP2=NVJP2+1                                                        HDIF.57
       NVJP1=NVJP1+1                                                        HDIF.58
       NKMHK=NKMHK+1                                                        HDIF.59
      ENDDO                                                                 HDIF.60
C     ****                                                                  HDIF.61
C     ****     CALCULATE RH*AVG(KMH) ON LINE J+1                            HDIF.62
C     ****                                                                  HDIF.63
C     ****     RH=M/(T+T0)                                                  HDIF.64
C     ****                                                                  HDIF.65
      NMSJPK=NJP1+NMS                                                       HDIF.66
      NTJP1K=NJP1+NTNM                                                      HDIF.67
      DO I=1,LEN2                                                           HDIF.68
       F(I,NRHK)=0.5*(F(I,NMSJPK)+F(I,NMSJPK+1))/F(I,NTJP1K)                HDIF.69
      ENDDO                                                                 HDIF.70
C     ****                                                                  HDIF.71
C     ****                   CALC AVG KMH VALUE AT EACH GRID PT ON J+1      HDIF.72
C     ****                                                                  HDIF.73
      NKMHK=NKMH                                                            HDIF.74
      IF(J.EQ.1)THEN                                                        HDIF.75
       DO K=1,KMAX                                                          HDIF.76
        DO I=2,LEN1-1                                                       HDIF.77
         S1(I,K)=0.5*(F(I,NKMHK)+F(I-1,NKMHK))                              HDIF.78
        ENDDO                                                               HDIF.70
        NKMHK=NKMHK+1                                                       HDIF.80
       ENDDO                                                                HDIF.81
      ELSE                                                                  HDIF.82
       DO K=1,KMAX                                                          HDIF.83
        DO I=2,LEN1-1                                                       HDIF.84
         S1(I,K)=0.25*(S2(I-1,K)+S2(I,K)+F(I-1,NKMHK)+F(I,NKMHK))           HDIF.85
        ENDDO                                                               HDIF.86
        NKMHK=NKMHK+1                                                       HDIF.87
       ENDDO                                                                HDIF.88
      ENDIF                                                                 HDIF.89
C     ****                                                                  HDIF.90
C     ****     S2=RHO*AVG(KMH)                                              HDIF.91
C     ****                                                                  HDIF.92
      NRHK=NRH                                                              HDIF.93
      DO I=1,LEN2                                                           HDIF.94
       S2(I,1)=S1(I,1)*F(I,NRHK)                                            HDIF.95
      ENDDO                                                                 HDIF.96
C     ****                                                                  HDIF.97
C     ****                   CALC RHO*KMH*(L*L(D*D)(PSI)) AT J+1 AND N-1    HDIF.98
C     ****                        FOR PSI = U                               HDIF.99
C     ****                                                                  HDIF.100
      NUNMP2=NJP2+NUNM                                                      HDIF.101
      NUNMP1=NJP1+NUNM                                                      HDIF.102
      NUNMK=NJ+NUNM                                                         HDIF.103
      NKLDUK=NJP1+NKLDU                                                     HDIF.104
      DO K=1,KMAX                                                           HDIF.105
       CALL N2LSQDSQ(J+1,F(1,NUNMP2),F(1,NUNMP1),F(1,NUNMK),S1(1,K),        HDIF.106
     1               LEN1-1)                                                HDIF.107
       DO I=2,LEN1-1                                                        HDIF.108
        F(I,NKLDUK)=S1(I-1,K)*S2(I,K)                                       HDIF.109
       ENDDO                                                                HDIF.110
       NUNMP2=NUNMP2+1                                                      HDIF.111
       NUNMP1=NUNMP1+1                                                      HDIF.112
       NUNMK=NUNMK+1                                                        HDIF.113
       NKLDUK=NKLDUK+1                                                      HDIF.114
      ENDDO                                                                 HDIF.115
C     ****                                                                  HDIF.116
C     ****                        FOR PSI = V                               HDIF.117
C     ****                                                                  HDIF.118
      NVNMP2=NJP2+NVNM                                                      HDIF.119
      NVNMP1=NJP1+NVNM                                                      HDIF.120
      NVNMK=NJ+NVNM                                                         HDIF.121
      NKLDVK=NJP1+NKLDV                                                     HDIF.122
      DO K=1,KMAX                                                           HDIF.123
       CALL N2LSQDSQ(J+1,F(1,NVNMP2),F(1,NVNMP1),F(1,NVNMK),S1(1,K),        HDIF.124
     1            LEN1-1)                                                   HDIF.125
       DO I=2,LEN1-1                                                        HDIF.126
        F(I,NKLDVK)=S1(I,K)*S2(I,K)                                         HDIF.127
       ENDDO                                                                HDIF.128
       NVNMP2=NVNMP2+1                                                      HDIF.129
       NVNMP1=NVNMP1+1                                                      HDIF.130
       NVNMK=NVNMK+1                                                        HDIF.131
       NKLDVK=NKLDVK+1                                                      HDIF.132
      ENDDO                                                                 HDIF.133
C     ****                                                                  HDIF.134
C     ****     FOR PSI=T                                                    HDIF.135
C     ****                                                                  HDIF.136
      NTNMP2=NJP2+NTNM                                                      HDIF.137
      NTNMP1=NJP1+NTNM                                                      HDIF.138
      NTNMK=NJ+NTNM                                                         HDIF.139
      NKLDTK=NJP1+NKLDT                                                     HDIF.140
      DO K=1,KMAX                                                           HDIF.141
       CALL N2LSQDSQ(J+1,F(1,NTNMP2),F(1,NTNMP1),F(1,NTNMK),S1(1,K),        HDIF.142
     1             LEN1-1)                                                  HDIF.143
       DO I=2,LEN1-1                                                        HDIF.144
        F(I,NKLDTK)=S1(I,K)*S2(I,K)                                         HDIF.145
       ENDDO                                                                HDIF.146
       NTNMP2=NTNMP2+1                                                      HDIF.147
       NTNMP1=NTNMP1+1                                                      HDIF.148
       NTNMK=NTNMK+1                                                        HDIF.149
       NKLDTK=NKLDTK+1                                                      HDIF.150
      ENDDO                                                                 HDIF.151
C     ****                                                                  HDIF.152
C     ****     FOR PSI=PS1                                                  HDIF.153
C     ****                                                                  HDIF.154
      DO L=1,2                                                              HDIF.155
       NPSK=NPSNM+(L-1)*KMAXP1                                              HDIF.156
       NPNMP2=NJP2+NPSK                                                     HDIF.157
       NPNMP1=NJP1+NPSK                                                     HDIF.158
       NPNMK=NJ+NPSK                                                        HDIF.159
       NKLDPK=NJP1+NKLDPS+(L-1)*KMAX                                        HDIF.160
       DO K=1,KMAX                                                          HDIF.161
        CALL N2LSQDSQ(J+1,F(1,NPNMP2),F(1,NPNMP1),F(1,NPNMK),S1(1,K),       HDIF.162
     1                LEN1-1)                                               HDIF.163
        DO I=2,LEN1-1                                                       HDIF.164
         F(I,NKLDPK)=S1(I,K)*S2(I,K)                                        HDIF.165
        ENDDO                                                               HDIF.166
        NPNMP2=NPNMP2+1                                                     HDIF.167
        NPNMP1=NPNMP1+1                                                     HDIF.168
        NPNMK=NPNMK+1                                                       HDIF.169
        NKLDPK=NKLDPK+1                                                     HDIF.170
       ENDDO                                                                HDIF.171
      ENDDO                                                                 HDIF.172
C     ****                                                                  HDIF.173
C     ****     FOR J.GE.1 CALCULATE FLH,FPH AND QDH                         HDIF.174
C     ****                                                                  HDIF.175
      IF(J.LE.1) RETURN                                                     HDIF.176
C     ****                                                                  HDIF.177
C     ****     FOR J=2 AND JMAX1 USE SECOND ORDER FORM                      HDIF.178
C     ****                                                                  HDIF.179
      IF(J.EQ.2.OR.J.EQ.JMAXM1)THEN                                         HDIF.180
        CALL N2HDIF1                                                        HDIF.181
        RETURN                                                              HDIF.182
      ENDIF                                                                 HDIF.183
C     ****                                                                  HDIF.184
C     ****     FOR J=3 TO JMAXM2 USE FOURTH ORDER FORM                      HDIF.185
C     ****                                                                  HDIF.186
C     ****                                                                  HDIF.187
C     ****     S2=-(T+T0)/M=-1./S4                                          HDIF.188
C     ****                                                                  HDIF.189
      DO I=1,LEN2                                                           HDIF.190
       S2(I,1)=-1./S4(I,1)                                                  HDIF.191
      ENDDO                                                                 HDIF.192
C     ****                                                                  HDIF.193
C     ****                   CALC FLH                                       HDIF.194
C     ****                                                                  HDIF.195
      NKLDPK=NJP1+NKLDU                                                     HDIF.196
      NKLDK=NJ+NKLDU                                                        HDIF.197
      NKLDMK=NJM1+NKLDU                                                     HDIF.198
      NFLHK=NFLH                                                            HDIF.199
      DO K=1,KMAX                                                           HDIF.200
        CALL N2LSQDSQ(J,F(1,NKLDPK),F(1,NKLDK),F(1,NKLDMK),S1(1,K),         HDIF.201
     1                LEN1-2)                                               HDIF.202
        DO I=3,LEN1-2                                                       HDIF.203
          F(I,NFLHK)=S1(I,K)*S2(I,K)                                        HDIF.204
        ENDDO                                                               HDIF.205
        NKLDPK=NKLDPK+1                                                     HDIF.206
        NKLDK=NKLDK+1                                                       HDIF.207
        NKLDMK=NKLDMK+1                                                     HDIF.208
        NFLHK=NFLHK+1                                                       HDIF.209
      ENDDO                                                                 HDIF.210
C     ****                                                                  HDIF.211
C     ****                   CALC FPH                                       HDIF.212
C     ****                                                                  HDIF.213
      NKLDPK=NJP1+NKLDV                                                     HDIF.214
      NKLDK=NJ+NKLDV                                                        HDIF.215
      NKLDMK=NJM1+NKLDV                                                     HDIF.216
      NFPHK=NFPH                                                            HDIF.217
      DO K=1,KMAX                                                           HDIF.218
        CALL N2LSQDSQ(J,F(1,NKLDPK),F(1,NKLDK),F(1,NKLDMK),S1(1,K),         HDIF.219
     1                LEN1-2)                                               HDIF.220
        DO I=3,LEN1-2                                                       HDIF.221
          F(I,NFPHK)=S1(I,K)*S2(I,K)                                        HDIF.222
        ENDDO                                                               HDIF.223
        NKLDPK=NKLDPK+1                                                     HDIF.224
        NKLDK=NKLDK+1                                                       HDIF.225
        NKLDMK=NKLDMK+1                                                     HDIF.226
        NFPHK=NFPHK+1                                                       HDIF.227
      ENDDO                                                                 HDIF.228
C     ****                                                                  HDIF.229
C     ****                   CALC QDH                                       HDIF.230
C     ****                                                                  HDIF.231
      NKLDPK=NJP1+NKLDT                                                     HDIF.232
      NKLDK=NJ+NKLDT                                                        HDIF.233
      NKLDMK=NJM1+NKLDT                                                     HDIF.234
      NQDHK=NQDH                                                            HDIF.235
      NCPK=NCP                                                              HDIF.236
      DO K=1,KMAX                                                           HDIF.237
        CALL N2LSQDSQ(J,F(1,NKLDPK),F(1,NKLDK),F(1,NKLDMK),S1(1,K),         HDIF.238
     1                LEN1-2)                                               HDIF.239
C       ****                                                                HDIF.240
C       ****     S3(K)=(CP(K)+CP(K+1))*.5                                   HDIF.241
C       ****                                                                HDIF.242
        DO I=3,LEN1-2                                                       HDIF.243
          S3(I,K)=(F(I,NCPK)+F(I,NCPK+1))*.5                                HDIF.244
          F(I,NQDHK)=S1(I,K)*S2(I,K)*S3(I,K)                                HDIF.245
        ENDDO                                                               HDIF.246
        NKLDPK=NKLDPK+1                                                     HDIF.247
        NKLDK=NKLDK+1                                                       HDIF.248
        NKLDMK=NKLDMK+1                                                     HDIF.249
        NQDHK=NQDHK+1                                                       HDIF.250
        NCPK=NCPK+1                                                         HDIF.251
      ENDDO                                                                 HDIF.252
C     ****                                                                  HDIF.253
C     ****     CALCULATE PSDH                                               HDIF.254
C     ****                                                                  HDIF.255
      DO L=1,2                                                              HDIF.256
       NKLK=NKLDPS+(L-1)*KMAX                                               HDIF.257
       NKLDPK=NJP1+NKLK                                                     HDIF.258
       NKLDK=NJ+NKLK                                                        HDIF.259
       NKLDMK=NJM1+NKLK                                                     HDIF.260
       NPSDHK=NPSDH+(L-1)*KMAX                                              HDIF.261
        DO K=1,KMAX                                                         HDIF.262
          CALL N2LSQDSQ(J,F(1,NKLDPK),F(1,NKLDK),F(1,NKLDMK),S1(1,K),       HDIF.263
     1               LEN1-2)                                                HDIF.264
          DO I=3,LEN1-2                                                     HDIF.265
            F(I,NPSDHK)=S1(I,K)*S2(I,K)                                     HDIF.266
          ENDDO                                                             HDIF.267
          NKLDPK=NKLDPK+1                                                   HDIF.268
          NKLK=NKLK+1                                                       HDIF.269
          NKLDK=NKLDK+1                                                     HDIF.270
          NKLDMK=NKLDMK+1                                                   HDIF.271
          NPSDHK=NPSDHK+1                                                   HDIF.272
        ENDDO                                                               HDIF.273
      ENDDO                                                                 HDIF.274
C     ****                                                                  HDIF.275
C     ****     CALCULATE BOUNADARY VALUES                                   HDIF.276
C     ****                                                                  HDIF.277
      CALL N2HDIF2(2)                                                       HDIF.278
      LEN=LEN1-1                                                            HDIF.279
      CALL N2HDIF2(LEN)                                                     HDIF.280
      RETURN                                                                HDIF.281
      END                                                                   HDIF.282
C                                                                           HDIF.283
*DK HDIF1                                                                   HDIF1.1
      SUBROUTINE N2HDIF1                                                    HDIF1.2
C                                                                           HDIF1.3
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC      HDIF1.4
C                                                                    C      HDIF1.5
C  Subroutine HDIF1 calculates the horizontal diffusion for the row  C      HDIF1.6
c  and column of grid points next to the laterial boundaries, we use C      HDIF1.7
c  second order form.                                                C      HDIF1.8
C  The code is written by Wenbin Wang.                               C      HDIF1.9
C                                                          12/16/94  C      HDIF1.10
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC      HDIF1.11
      INCLUDE 'n2param.h'                                                   HDIF1.12
      INCLUDE 'n2array.h'                                                   HDIF1.13
      INCLUDE 'n2cvscr.h'                                                   HDIF1.14
      INCLUDE 'n2const.h'                                                   HDIF1.15
      INCLUDE 'index.h'                                                     HDIF1.16
      INCLUDE 'buffe.h'                                                     HDIF1.17
      INCLUDE 'n2phycs.h'                                                   HDIF1.18
      DIMENSION DTM(IMX,KMX),DSM(IMX,KMX),DTP(IMX,KMX)                      HDIF1.20
      DIMENSION DSP(IMX,KMX),AQP(IMX,KMX),BQP(IMX,KMX),                     HDIF1.21
     &AQM(IMX,KMX),BQM(IMX,KMX),RR(IMX,KMX),AP1P(IMX,KMX),                  HDIF1.22
     &BP1P(IMX,KMX),AP1M(IMX,KMX),BP1M(IMX,KMX),AP2P(IMX,KMX),              HDIF1.23
     &BP2P(IMX,KMX),AP2M(IMX,KMX),BP2M(IMX,KMX)                             HDIF1.24
      NMSM1K=NJM1+NMS                                                       HDIF1.25
      NMSJK=NJ+NMS                                                          HDIF1.26
      NUJM1K=NJM1+NUNM                                                      HDIF1.27
      NUJK=NJ+NUNM                                                          HDIF1.28
      NUJP1K=NJP1+NUNM                                                      HDIF1.29
      NVJM1K=NJM1+NVNM                                                      HDIF1.30
      NVJK=NJ+NVNM                                                          HDIF1.31
      NVJP1K=NJP1+NVNM                                                      HDIF1.32
      NTJM1K=NJM1+NTNM                                                      HDIF1.33
      NTJK=NJ+NTNM                                                          HDIF1.34
      NTJP1K=NJP1+NTNM                                                      HDIF1.35
      NP1JM1K=NJM1+NPSNM                                                    HDIF1.36
      NP1JK=NJ+NPSNM                                                        HDIF1.37
      NP1JP1K=NJP1+NPSNM                                                    HDIF1.38
      NP2JM1K=NJM1+NPS2NM                                                   HDIF1.39
      NP2JK=NJ+NPS2NM                                                       HDIF1.40
      NP2JP1K=NJP1+NPS2NM                                                   HDIF1.41
      ABCSJM=DABS(CS(J-1))                                                  HDIF1.42
      ABCSJ=DABS(CS(J))                                                     HDIF1.43
      ABCSJP=DABS(CS(J+1))                                                  HDIF1.44
      CON1=C(52)*.5/C(1)                                                    HDIF1.45
      CON2=C(52)/(C(2)*(ABCSJ+ABCSJM))                                      HDIF1.46
      CON3=2.*C(109)*C(109)                                                 HDIF1.47
      CON4=C(51)*C(2)                                                       HDIF1.48
      DO K=1,KMAX                                                           HDIF1.49
        DO I=1,LEN1-1                                                       HDIF1.50
          RHK=0.5*(F(I,NMSJK)+F(I,NMSJK+1))/F(I,NTJK)                       HDIF1.51
          DTX=CON1*((F(I+1,NUJK)-F(I,NUJK))/CS(J)+                          HDIF1.52
     1        (F(I+1,NUJM1K)-F(I,NUJM1K))/CS(J-1))-                         HDIF1.53
     2        CON2*((F(I+1,NVJK)+F(I,NVJK))*ABCSJ-                          HDIF1.54
     3        (F(I+1,NVJM1K)+F(I,NVJM1K))*ABCSJM)                           HDIF1.55
          DSX=CON1*((F(I+1,NVJK)-F(I,NVJK))/CS(J)+                          HDIF1.56
     1        (F(I+1,NVJM1K)-F(I,NVJM1K))/CS(J-1))+                         HDIF1.57
     2        CON2*((F(I+1,NUJK)+F(I,NUJK))*ABCSJ-                          HDIF1.58
     3        (F(I+1,NUJM1K)+F(I,NUJM1K))*ABCSJM)                           HDIF1.59
          AQMX=0.5/C(2)*(F(I+1,NTJK)-F(I,NTJK)+F(I+1,NTJM1K)-               HDIF1.60
     1         F(I,NTJM1K))                                                 HDIF1.61
          BQMX=0.25/C(1)*(CS(J-1)+CS(J))*(F(I+1,NTJK)-                      HDIF1.62
     1         F(I+1,NTJM1K)+F(I,NTJK)-F(I,NTJM1K))                         HDIF1.63
          AP1MX=0.5/C(2)*(F(I+1,NP1JK)-F(I,NP1JK)+F(I+1,NP1JM1K)-           HDIF1.64
     1         F(I,NP1JM1K))                                                HDIF1.65
          BP1MX=0.25/C(1)*(CS(J-1)+CS(J))*(F(I+1,NP1JK)-                    HDIF1.66
     1          F(I+1,NP1JM1K)+F(I,NP1JK)-F(I,NP1JM1K))                     HDIF1.67
          AP2MX=0.5/C(2)*(F(I+1,NP2JK)-F(I,NP2JK)+F(I+1,NP2JM1K)-           HDIF1.68
     1          F(I,NP2JM1K))                                               HDIF1.69
          BP2MX=0.25/C(1)*(CS(J-1)+CS(J))*(F(I+1,NP2JK)-                    HDIF1.70
     1          F(I+1,NP2JM1K)+F(I,NP2JK)-F(I,NP2JM1K))                     HDIF1.71
          FHK=CON3*CON4*CON4*DSQRT(DSX*DSX+DTX*DTX)                         HDIF1.72
          DTM(I,K)=RHK*FHK*DTX                                              HDIF1.73
          DSM(I,K)=RHK*FHK*DSX                                              HDIF1.74
          AQM(I,K)=FHK*AQMX*RHK                                             HDIF1.75
          BQM(I,K)=FHK*BQMX*RHK                                             HDIF1.76
          AP1M(I,K)=FHK*AP1MX*RHK                                           HDIF1.77
          BP1M(I,K)=FHK*BP1MX*RHK                                           HDIF1.78
          AP2M(I,K)=FHK*AP2MX*RHK                                           HDIF1.79
          BP2M(I,K)=FHK*BP2MX*RHK                                           HDIF1.80
          DTX=CON1*((F(I+1,NUJP1K)-F(I,NUJP1K))/CS(J+1)+                    HDIF1.81
     1        (F(I+1,NUJK)-F(I,NUJK))/CS(J))-                               HDIF1.82
     2        CON2*((F(I+1,NVJP1K)+F(I,NVJP1K))*ABCSJP-                     HDIF1.83
     3        (F(I+1,NVJK)+F(I,NVJK))*ABCSJ)                                HDIF1.84
          DSX=CON1*((F(I+1,NVJP1K)-F(I,NVJP1K))/CS(J+1)+                    HDIF1.85
     1        (F(I+1,NVJK)-F(I,NVJK))/CS(J))+                               HDIF1.86
     2        CON2*((F(I+1,NUJP1K)+F(I,NUJP1K))*ABCSJP-                     HDIF1.87
     3        (F(I+1,NUJK)+F(I,NUJK))*ABCSJ)                                HDIF1.88
          AQPX=0.5/C(2)*(F(I+1,NTJP1K)-F(I,NTJP1K)+F(I+1,NTJK)-             HDIF1.89
     1         F(I,NTJK))                                                   HDIF1.90
          BQPX=0.25/C(1)*(CS(J)+CS(J+1))*(F(I+1,NTJP1K)-                    HDIF1.91
     1         F(I+1,NTJK)+F(I,NTJP1K)-F(I,NTJK))                           HDIF1.92
          AP1PX=0.5/C(2)*(F(I+1,NP1JP1K)-F(I,NP1JP1K)+F(I+1,NP1JK)-         HDIF1.93
     1         F(I,NP1JK))                                                  HDIF1.94
          BP1PX=0.25/C(1)*(CS(J)+CS(J+1))*(F(I+1,NP1JP1K)-                  HDIF1.95
     1         F(I+1,NP1JK)+F(I,NP1JP1K)-F(I,NP1JK))                        HDIF1.96
          AP2PX=0.5/C(2)*(F(I+1,NP2JP1K)-F(I,NP2JP1K)+F(I+1,NP2JK)-         HDIF1.97
     1         F(I,NP2JK))                                                  HDIF1.98
          BP2PX=0.25/C(1)*(CS(J)+CS(J+1))*(F(I+1,NP2JP1K)-                  HDIF1.99
     1         F(I+1,NP2JK)+F(I,NP2JP1K)-F(I,NP2JK))                        HDIF1.100
          FHK=CON3*CON4*CON4*DSQRT(DSX*DSX+DTX*DTX)                         HDIF1.101
          DTP(I,K)=RHK*FHK*DTX                                              HDIF1.102
          DSP(I,K)=RHK*FHK*DSX                                              HDIF1.103
          AQP(I,K)=FHK*AQPX*RHK                                             HDIF1.104
          BQP(I,K)=FHK*BQPX*RHK                                             HDIF1.105
          AP1P(I,K)=FHK*AP1PX*RHK                                           HDIF1.106
          BP1P(I,K)=FHK*BP1PX*RHK                                           HDIF1.107
          AP2P(I,K)=FHK*AP2PX*RHK                                           HDIF1.108
          BP2P(I,K)=FHK*BP2PX*RHK                                           HDIF1.109
          RR(I,K)=0.5*(F(I,NMSM1K)+F(I,NMSM1K+1))/F(I,NTJM1K)               HDIF1.110
        ENDDO                                                               HDIF1.111
        NMSM1K=NMSM1K+1                                                     HDIF1.112
        NMSJK=NMSJK+1                                                       HDIF1.113
        NUJM1K=NUJM1K+1                                                     HDIF1.114
        NUJK=NUJK+1                                                         HDIF1.115
        NUJP1K=NUJP1K+1                                                     HDIF1.116
        NVJM1K=NVJM1K+1                                                     HDIF1.117
        NVJK=NVJK+1                                                         HDIF1.118
        NVJP1K=NVJP1K+1                                                     HDIF1.119
        NTJM1K=NTJM1K+1                                                     HDIF1.120
        NTJK=NTJK+1                                                         HDIF1.121
        NTJP1K=NTJP1K+1                                                     HDIF1.122
        NP1JM1K=NP1JM1K+1                                                   HDIF1.123
        NP1JK=NP1JK+1                                                       HDIF1.124
        NP1JP1K=NP1JP1K+1                                                   HDIF1.125
        NP2JM1K=NP2JM1K+1                                                   HDIF1.126
        NP2JK=NP2JK+1                                                       HDIF1.127
        NP2JP1K=NP2JP1K+1                                                   HDIF1.128
      ENDDO                                                                 HDIF1.129
      NFLHK=NFLH                                                            HDIF1.130
      NFPHK=NFPH                                                            HDIF1.131
      NQDHK=NQDH                                                            HDIF1.132
      NPSDHK=NPSDH                                                          HDIF1.133
      NPS2DHK=NPSDHK+KMAX                                                   HDIF1.134
      NCPK=NCP	                                                            HDIF1.135
      CON5=C(52)*0.5/C(2)                                                   HDIF1.136
      CON6=C(52)/CS(J)                                                      HDIF1.137
      DO K=1,KMAX                                                           HDIF1.138
        DO I=2,LEN1-1                                                       HDIF1.139
          F(I,NFLHK)=CON1*(DTP(I,K)-DTP(I-1,K)+                             HDIF1.140
     1               DTM(I,K)-DTM(I-1,K))/CS(J)+                            HDIF1.141
     2               CON5*(DSP(I,K)-DSP(I-1,K)+                             HDIF1.142
     3               DSM(I,K)-DSM(I-1,K))                                   HDIF1.143
          F(I,NFPHK)=CON1*(DSP(I,K)-DSP(I-1,K) +                            HDIF1.144
     1               DSM(I,K)-DSM(I-1,K))/CS(J)-                            HDIF1.145
     2               CON5*(DTP(I,K)-DTP(I-1,K)+                             HDIF1.146
     3               DTM(I,K)-DTM(I-1,K))                                   HDIF1.147
          F(I,NQDHK)=CON6*F(I,NCPK)*(CON5/CS(J)*(AQP(I,K)-                  HDIF1.148
     1               AQP(I-1,K)+AQM(I,K)-AQM(I-1,K))+                       HDIF1.149
     2               CON1*(BQP(I,K)-BQM(I,K)+BQP(I-1,K)-BQM(I-1,K)))        HDIF1.150
         F(I,NPSDHK)=CON6*(CON5/CS(J)*(AP1P(I,K)-                           HDIF1.151
     1                AP1P(I-1,K)+AP1M(I,K)-AP1M(I-1,K))+CON1*              HDIF1.152
     2                (BP1P(I,K)-BP1M(I,K)+BP1P(I-1,K)-BP1M(I-1,K)))        HDIF1.153
          F(I,NPS2DHK)=CON6*(CON5/CS(J)*(AP2P(I,K)-                         HDIF1.154
     1                 AP2P(I-1,K)+AP2M(I,K)-AP2M(I-1,K))+CON1*             HDIF1.155
     2                 (BP2P(I,K)-BP2M(I,K)+BP2P(I-1,K)-BP2M(I-1,K)))       HDIF1.156
          F(I,NFLHK)=F(I,NFLHK)/RR(I,K)                                     HDIF1.157
          F(I,NFPHK)=F(I,NFPHK)/RR(I,K)                                     HDIF1.158
          F(I,NQDHK)=F(I,NQDHK)/RR(I,K)                                     HDIF1.159
          F(I,NPSDHK)=F(I,NPSDHK)/RR(I,K)                                   HDIF1.160
          F(I,NPS2DHK)=F(I,NPS2DHK)/RR(I,K)                                 HDIF1.161
        ENDDO                                                               HDIF1.162
        NFLHK=NFLHK+1                                                       HDIF1.163
        NFPHK=NFPHK+1                                                       HDIF1.164
        NQDHK=NQDHK+1                                                       HDIF1.165
        NPSDHK=NPSDHK+1                                                     HDIF1.166
        NPS2DHK=NPS2DHK+1                                                   HDIF1.167
        NCPK=NCPK+1                                                         HDIF1.168
      ENDDO                                                                 HDIF1.169
      RETURN                                                                HDIF1.170
      END                                                                   HDIF1.171
C                                                                           HDIF1.172
*DK HDIF2                                                                   HDIF2.1
      SUBROUTINE N2HDIF2(I)                                                 HDIF2.2
C                                                                           HDIF2.3
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC      HDIF2.4
C                                                                    C      HDIF2.5
C  Subroutine HDIF2 calculates the horizontal diffusion for the row  C      HDIF2.6
c  and column of grid points next to the laterial boundaries, we use C      HDIF2.7
c  second order form.                                                C      HDIF2.8
C  The code is written by Wenbin Wang.                               C      HDIF2.9
C                                                          12/16/94  C      HDIF2.10
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC      HDIF2.11
      INCLUDE 'n2param.h'                                                   HDIF2.12
      INCLUDE 'n2array.h'                                                   HDIF2.13
      INCLUDE 'n2cvscr.h'                                                   HDIF2.14
      INCLUDE 'n2const.h'                                                   HDIF2.15
      INCLUDE 'index.h'                                                     HDIF2.16
      INCLUDE 'buffe.h'                                                     HDIF2.17
      INCLUDE 'n2phycs.h'                                                   HDIF2.18
      DIMENSION DTM(IMX,KMX),DSM(IMX,KMX),DTP(IMX,KMX)                      HDIF2.20
      DIMENSION DSP(IMX,KMX),AQP(IMX,KMX),BQP(IMX,KMX),                     HDIF2.21
     &AQM(IMX,KMX),BQM(IMX,KMX),RR(IMX,KMX),AP1P(IMX,KMX),                  HDIF2.22
     &BP1P(IMX,KMX),AP1M(IMX,KMX),BP1M(IMX,KMX),AP2P(IMX,KMX),              HDIF2.23
     &BP2P(IMX,KMX),AP2M(IMX,KMX),BP2M(IMX,KMX)                             HDIF2.24
      NMSM1K=NJM1+NMS                                                       HDIF2.25
      NMSJK=NJ+NMS                                                          HDIF2.26
      NUJM1K=NJM1+NUNM                                                      HDIF2.27
      NUJK=NJ+NUNM                                                          HDIF2.28
      NUJP1K=NJP1+NUNM                                                      HDIF2.29
      NVJM1K=NJM1+NVNM                                                      HDIF2.30
      NVJK=NJ+NVNM                                                          HDIF2.31
      NVJP1K=NJP1+NVNM                                                      HDIF2.32
      NTJM1K=NJM1+NTNM                                                      HDIF2.33
      NTJK=NJ+NTNM                                                          HDIF2.34
      NTJP1K=NJP1+NTNM                                                      HDIF2.35
      NP1JM1K=NJM1+NPSNM                                                    HDIF2.36
      NP1JK=NJ+NPSNM                                                        HDIF2.37
      NP1JP1K=NJP1+NPSNM                                                    HDIF2.38
      NP2JM1K=NJM1+NPS2NM                                                   HDIF2.39
      NP2JK=NJ+NPS2NM                                                       HDIF2.40
      NP2JP1K=NJP1+NPS2NM                                                   HDIF2.41
      ABCSJM=DABS(CS(J-1))                                                  HDIF2.42
      ABCSJ=DABS(CS(J))                                                     HDIF2.43
      ABCSJP=DABS(CS(J+1))                                                  HDIF2.44
      CON1=C(52)*.5/C(1)                                                    HDIF2.45
      CON2=C(52)/(C(2)*(ABCSJ+ABCSJM))                                      HDIF2.46
      CON3=2.*C(109)*C(109)                                                 HDIF2.47
      CON4=C(51)*C(2)                                                       HDIF2.48
      DO K=1,KMAX                                                           HDIF2.49
        DO L=I-1,I                                                          HDIF2.50
          RHK=0.5*(F(L,NMSJK)+F(L,NMSJK+1))/F(L,NTJK)                       HDIF2.51
          DTX=CON1*((F(L+1,NUJK)-F(L,NUJK))/CS(J)+                          HDIF2.52
     1        (F(L+1,NUJM1K)-F(L,NUJM1K))/CS(J-1))-                         HDIF2.53
     2        CON2*((F(L+1,NVJK)+F(L,NVJK))*ABCSJ-                          HDIF2.54
     3        (F(L+1,NVJM1K)+F(L,NVJM1K))*ABCSJM)                           HDIF2.55
          DSX=CON1*((F(L+1,NVJK)-F(L,NVJK))/CS(J)+                          HDIF2.56
     1        (F(L+1,NVJM1K)-F(L,NVJM1K))/CS(J-1))+                         HDIF2.57
     2        CON2*((F(L+1,NUJK)+F(L,NUJK))*ABCSJ-                          HDIF2.58
     3        (F(L+1,NUJM1K)+F(L,NUJM1K))*ABCSJM)                           HDIF2.59
          AQMX=0.5/C(2)*(F(L+1,NTJK)-F(L,NTJK)+F(L+1,NTJM1K)-               HDIF2.60
     1        F(L,NTJM1K))                                                  HDIF2.61
          BQMX=0.25/C(1)*(CS(J)+CS(J+1))*(F(L+1,NTJK)-                      HDIF2.62
     1        F(L+1,NTJM1K)+F(L,NTJK)-F(L,NTJM1K))                          HDIF2.63
          AP1MX=0.5/C(2)*(F(L+1,NP1JK)-F(L,NP1JK)+F(L+1,NP1JM1K)-           HDIF2.64
     1         F(L,NP1JM1K))                                                HDIF2.65
          BP1MX=0.25/C(1)*(CS(J-1)+CS(J))*(F(L+1,NP1JK)-                    HDIF2.66
     1           F(L+1,NP1JM1K)+F(L,NP1JK)-F(L,NP1JM1K))                    HDIF2.67
          AP2MX=0.5/C(2)*(F(L+1,NP2JK)-F(L,NP2JK)+F(L+1,NP2JM1K)-           HDIF2.68
     1           F(L,NP2JM1K))                                              HDIF2.69
          BP2MX=0.25/C(1)*(CS(J-1)+CS(J))*(F(L+1,NP2JK)-                    HDIF2.70
     1           F(L+1,NP2JM1K)+F(L,NP2JK)-F(L,NP2JM1K))                    HDIF2.71
          FHK=CON3*CON4*CON4*DSQRT(DSX*DSX+DTX*DTX)                         HDIF2.72
          DTM(L,K)=RHK*FHK*DTX                                              HDIF2.73
          DSM(L,K)=RHK*FHK*DSX                                              HDIF2.74
          AQM(L,K)=FHK*AQMX*RHK                                             HDIF2.75
          BQM(L,K)=FHK*BQMX*RHK                                             HDIF2.76
          AP1M(L,K)=FHK*AP1MX*RHK                                           HDIF2.77
          BP1M(L,K)=FHK*BP1MX*RHK                                           HDIF2.78
          AP2M(L,K)=FHK*AP2MX*RHK                                           HDIF2.79
          BP2M(L,K)=FHK*BP2MX*RHK                                           HDIF2.80
          DTX=CON1*((F(L+1,NUJP1K)-F(L,NUJP1K))/CS(J+1)+                    HDIF2.81
     1        (F(L+1,NUJK)-F(L,NUJK))/CS(J))-                               HDIF2.82
     2        CON2*((F(L+1,NVJP1K)+F(L,NVJP1K))*ABCSJP-                     HDIF2.83
     3        (F(L+1,NVJK)+F(L,NVJK))*ABCSJ)                                HDIF2.84
          DSX=CON1*((F(L+1,NVJP1K)-F(L,NVJP1K))/CS(J+1)+                    HDIF2.85
     1        (F(L+1,NVJK)-F(L,NVJK))/CS(J))+                               HDIF2.86
     2        CON2*((F(L+1,NUJP1K)+F(L,NUJP1K))*ABCSJP-                     HDIF2.87
     3        (F(L+1,NUJK)+F(L,NUJK))*ABCSJ)                                HDIF2.88
          AQPX=0.5/C(2)*(F(L+1,NTJP1K)-F(L,NTJP1K)+F(L+1,NTJK)-             HDIF2.89
     1         F(L,NTJK))                                                   HDIF2.90
          BQPX=0.25/C(1)*(CS(J)+CS(J+1))*(F(L+1,NTJP1K)-                    HDIF2.91
     1         F(L+1,NTJK)+F(L,NTJP1K)-F(L,NTJK))                           HDIF2.92
          AP1PX=0.5/C(2)*(F(L+1,NP1JP1K)-F(L,NP1JP1K)+F(L+1,NP1JK)-         HDIF2.93
     1         F(L,NP1JK))                                                  HDIF2.94
          BP1PX=0.25/C(1)*(CS(J)+CS(J+1))*(F(L+1,NP1JP1K)-                  HDIF2.95
     1         F(L+1,NP1JK)+F(L,NP1JP1K)-F(L,NP1JK))                        HDIF2.96
          AP2PX=0.5/C(2)*(F(L+1,NP2JP1K)-F(L,NP2JP1K)+F(L+1,NP2JK)-         HDIF2.97
     1         F(L,NP2JK))                                                  HDIF2.98
          BP2PX=0.25/C(1)*(CS(J)+CS(J+1))*(F(L+1,NP2JP1K)-                  HDIF2.99
     1         F(L+1,NP2JK)+F(L,NP2JP1K)-F(L,NP2JK))                        HDIF2.100
          FHK=CON3*CON4*CON4*DSQRT(DSX*DSX+DTX*DTX)                         HDIF2.101
          DTP(L,K)=RHK*FHK*DTX                                              HDIF2.102
          DSP(L,K)=RHK*FHK*DSX                                              HDIF2.103
          AQP(L,K)=FHK*AQPX*RHK                                             HDIF2.104
          BQP(L,K)=FHK*BQPX*RHK                                             HDIF2.105
          AP1P(L,K)=FHK*AP1PX*RHK                                           HDIF2.106
          BP1P(L,K)=FHK*BP1PX*RHK                                           HDIF2.107
          AP2P(L,K)=FHK*AP2PX*RHK                                           HDIF2.108
          BP2P(L,K)=FHK*BP2PX*RHK                                           HDIF2.109
          RR(L,K)=0.5*(F(L,NMSM1K)+F(L,NMSM1K+1))/F(L,NTJM1K)               HDIF2.110
        ENDDO                                                               HDIF2.111
        NMSM1K=NMSM1K+1                                                     HDIF2.112
        NMSJK=NMSJK+1                                                       HDIF2.113
        NUJM1K=NUJM1K+1                                                     HDIF2.114
        NUJK=NUJK+1                                                         HDIF2.115
        NUJP1K=NUJP1K+1                                                     HDIF2.116
        NVJM1K=NVJM1K+1                                                     HDIF2.117
        NVJK=NVJK+1                                                         HDIF2.118
        NVJP1K=NVJP1K+1                                                     HDIF2.119
        NTJM1K=NTJM1K+1                                                     HDIF2.120
        NTJK=NTJK+1                                                         HDIF2.121
        NTJP1K=NTJP1K+1                                                     HDIF2.122
        NP1JM1K=NP1JM1K+1                                                   HDIF2.123
        NP1JK=NP1JK+1                                                       HDIF2.124
        NP1JP1K=NP1JP1K+1                                                   HDIF2.125
        NP2JM1K=NP2JM1K+1                                                   HDIF2.126
        NP2JK=NP2JK+1                                                       HDIF2.127
        NP2JP1K=NP2JP1K+1                                                   HDIF2.128
      ENDDO                                                                 HDIF2.129
      NFLHK=NFLH                                                            HDIF2.130
      NFPHK=NFPH                                                            HDIF2.131
      NQDHK=NQDH                                                            HDIF2.132
      NPSDHK=NPSDH                                                          HDIF2.133
      NPS2DHK=NPSDHK+KMAX                                                   HDIF2.134
      NCPK=NCP	                                                            HDIF2.135
      CON5=C(52)*0.5/C(2)                                                   HDIF2.136
      CON6=C(52)/CS(J)                                                      HDIF2.137
      DO K=1,KMAX                                                           HDIF2.138
        F(I,NFLHK)=CON1*(DTP(I,K)-DTP(I-1,K)+                               HDIF2.139
     1             DTM(I,K)-DTM(I-1,K))/CS(J)+                              HDIF2.140
     2             CON5*(DSP(I,K)-DSP(I-1,K)+                               HDIF2.141
     3             DSM(I,K)-DSM(I-1,K))                                     HDIF2.142
        F(I,NFPHK)=CON1*(DSP(I,K)-DSP(I-1,K) +                              HDIF2.143
     1             DSM(I,K)-DSM(I-1,K))/CS(J)-                              HDIF2.144
     2             CON5*(DTP(I,K)-DTP(I-1,K)+                               HDIF2.145
     3             DTM(I,K)-DTM(I-1,K))                                     HDIF2.146
        F(I,NQDHK)=CON6*F(I,NCPK)*(CON5/CS(J)*(AQP(I,K)-                    HDIF2.147
     1             AQP(I-1,K)+AQM(I,K)-AQM(I-1,K))+                         HDIF2.148
     2             CON1*(BQP(I,K)-BQM(I,K)+BQP(I-1,K)-BQM(I-1,K)))          HDIF2.149
       F(I,NPSDHK)=CON6*(CON5/CS(J)*(AP1P(I,K)-                             HDIF2.150
     1              AP1P(I-1,K)+AP1M(I,K)-AP1M(I-1,K))+CON1*                HDIF2.151
     2              (BP1P(I,K)-BP1M(I,K)+BP1P(I-1,K)-BP1M(I-1,K)))          HDIF2.152
        F(I,NPS2DHK)=CON6*(CON5/CS(J)*(AP2P(I,K)-                           HDIF2.153
     1               AP2P(I-1,K)+AP2M(I,K)-AP2M(I-1,K))+CON1*               HDIF2.154
     2               (BP2P(I,K)-BP2M(I,K)+BP2P(I-1,K)-BP2M(I-1,K)))         HDIF2.155
        F(I,NFLHK)=F(I,NFLHK)/RR(I,K)                                       HDIF2.156
        F(I,NFPHK)=F(I,NFPHK)/RR(I,K)                                       HDIF2.157
        F(I,NQDHK)=F(I,NQDHK)/RR(I,K)                                       HDIF2.158
        F(I,NPSDHK)=F(I,NPSDHK)/RR(I,K)                                     HDIF2.159
        F(I,NPS2DHK)=F(I,NPS2DHK)/RR(I,K)                                   HDIF2.160
        NFLHK=NFLHK+1                                                       HDIF2.161
        NFPHK=NFPHK+1                                                       HDIF2.162
        NQDHK=NQDHK+1                                                       HDIF2.163
        NPSDHK=NPSDHK+1                                                     HDIF2.164
        NPS2DHK=NPS2DHK+1                                                   HDIF2.165
        NCPK=NCPK+1                                                         HDIF2.166
      ENDDO                                                                 HDIF2.167
      RETURN                                                                HDIF2.169
      END                                                                   HDIF2.169
C                                                                           HDIF2.170
*DK HEELIS                                                                HEELIS.1
      SUBROUTINE N2HEELIS(LEVEL)                                          HEELIS.2
C     ****                                                                HEELIS.3
C     ****     GENERATE AURORAL CIRCLE FIELDS, UI, VI, WI                 HEELIS.4
C     ****                                                                HEELIS.5
      INCLUDE 'n2param.h'                                                 HEELIS.6
      INCLUDE 'n2array.h'                                                 HEELIS.6
      INCLUDE 'n2cvscr.h'                                                 HEELIS.7
      INCLUDE 'n2const.h'                                                 HEELIS.8
      INCLUDE 'index.h'                                                   HEELIS.9
      INCLUDE 'start.h'                                                   HEELIS.10
      INCLUDE 'buffe.h'                                                   HEELIS.11
      INCLUDE 'n2phycs.h'                                                 HEELIS.12
      INCLUDE 'nestcnt.h'
      COMMON/N2MAGFLD/BX(IMX,JMX),BY(IMX,JMX),BZ(IMX,JMX),BMOD(IMX,JMX)
      COMMON/IONDRIFT2/SU(IMX,KMXP,JMX),SV(IMX,KMXP,JMX),
     1                SW(IMX,KMXP,JMX)
C     ****                                                                HEELIS.16
C     ****     CALCULATE UI AND VI                                        HEELIS.17
C     ****                                                                HEELIS.18
C     ****     SCALE UI AND VI FROM INPUT                                 HEELIS.19
C     ****                                                                HEELIS.20
      NUIK=NUI                                                            HEELIS.21
      NVIK=NVI                                                            HEELIS.22
      NWIK=NWI                                                            HEELIS.23
      DO K=1,KMAXP1
       DO I=1,LEN1                                                        HEELIS.24
        F(I,NUIK)=100.*SU(I,K,J)                                            HEELIS.25
        F(I,NVIK)=100.*SV(I,K,J)                                            HEELIS.26
        F(I,NWIK)=100.*SW(I,K,J)                                            HEELIS.27
       ENDDO
      NUIK=NUIK+1                                                         HEELIS.21
      NVIK=NVIK+1                                                         HEELIS.22
      NWIK=NWIK+1                                                         HEELIS.23
      ENDDO                                                               HEELIS.28
      USERLA=PHIS(LEVEL)*C(110)/180.+DBLE(J-1)*C(2)                       HEELIS.29
      ISHUNK=1                                                            HEELIS.30
      IF(DABS(USERLA).LT.C(110)/6.)ISHUNK=0                               HEELIS.31
      IF(ISHUNK.EQ.0)GO TO 24                                             HEELIS.32
      CALL N2FLOWION(T5(1),T6(1),T7(1),T8(1),T9(1),T3(1))                 HEELIS.34
      GO TO 25                                                            HEELIS.52
   24 CONTINUE                                                            HEELIS.53
      DO I=1,LEN1                                                         HEELIS.54
       T3(I)=0.                                                           HEELIS.55
       T5(I)=0.                                                           HEELIS.56
       T6(I)=0.                                                           HEELIS.57
       T7(I)=0.                                                           HEELIS.58
       T8(I)=0.                                                           HEELIS.59
       T9(I)=0.                                                           HEELIS.60
      ENDDO                                                               HEELIS.61
   25 CONTINUE                                                            HEELIS.62
      RETURN                                                              HEELIS.63
      END                                                                 HEELIS.64
C                                                                         HEELIS.65
*DK HISTIN                                                                HISTIN.1
      SUBROUTINE N2HISTIN(LEVEL)                                          HISTIN.2
      INCLUDE 'n2param.h'                                                 HISTIN.3
      INCLUDE 'nestcnt.h'                                                 HISTIN.4
      INCLUDE 'n2const.h'                                                 HISTIN.5
      INCLUDE 'n2array.h'                                                 HISTIN.6
      INCLUDE 'start.h'                                                   HISTIN.7
C     ****                                                                HISTIN.8
C     ****     PERFORM LINEAR INTERPOLATION OF THE COARSE GRID FOR THE    HISTIN.9
C     ****     INITIALIZATION OF THE NESTED GRID                          HISTIN.10
C     ****                                                                HISTIN.11
      CALL N2NESTIN(G,NHIST,LEVEL)                                        HISTIN.12
      RETURN                                                              HISTIN.13
      END                                                                 HISTIN.14
C                                                                         HISTIN.15
*DK LAMDAS                                                                LAMDAS.1
      SUBROUTINE N2LAMDAS                                                 LAMDAS.2
C     ****                                                                LAMDAS.3
C     ****     COMPUTE ION DRAG COEFFICIENTS                              LAMDAS.4
C     ****                                                                LAMDAS.5
C     ****     MAJOR SPECIES AND IONS ARE NUMBERED THUS                   LAMDAS.6
C     ****       O2  -  1            O2+  -  1                            LAMDAS.7
C     ****       O   -  2            O+   -  2                            LAMDAS.8
C     ****       N2  -  3            N2+  -  3                            LAMDAS.9
C     ****                                                                LAMDAS.10
      INCLUDE 'n2param.h'                                                 LAMDAS.11
      INCLUDE 'n2array.h'                                                 LAMDAS.1
      INCLUDE 'n2const.h'                                                 LAMDAS.12
      INCLUDE 'index.h'                                                   LAMDAS.13
      INCLUDE 'buffe.h'                                                   LAMDAS.14
      INCLUDE 'n2phycs.h'                                                  LAMDAS.15
      INCLUDE 'n2edyna.h'                                                 LAMDAS.16
      COMMON/N2TRGM/RLATM(IMX,JMX),RLONM(IMX,JMX),                         LAMDAS.17
     1      DIPMAG(IMX,JMX),DECMAG(IMX,JMX),SNDEC(IMX,JMX),               LAMDAS.18
     2      CSDEC(IMX,JMX),SN2DEC(IMX,JMX),SNCSDC(IMX,JMX),               LAMDAS.19
     3      RLATMP(JMX),RLONMP(JMX),DLONS(JMX)                            LAMDAS.20
      COMMON/N2MAGFLD/BX(IMX,JMX),BY(IMX,JMX),BZ(IMX,JMX),BMOD(IMX,JMX)
      DIMENSION RM(IMX,KMXP,3,3),V1(IMX,KMXP),V2(IMX,KMXP),               LAMDAS.24
     1          V3(IMX,KMXP),V4(IMX,KMXP),V5(IMX,KMXP),                   LAMDAS.25
     2          V6(IMX,KMXP),T1(IMX),T2(IMX),T3(IMX),T4(IMX)              LAMDAS.26
      DIMENSION RMS(3)                                                    LAMDAS.27
      DATA RMS/32.,16.,30./,QE/1.602D-19/                                 LAMDAS.28
C     ****                                                                LAMDAS.29
C     ****     T1 = BGAUSS                                                LAMDAS.30
C     ****     T2 = 9.6489D3 * BGAUS    ( FOR OMEGA(I) )                  LAMDAS.31
C     ****     T3 = 1.7588028D7 * BGAUSS  ( FOR OMEGA(E) )                LAMDAS.32
C     ****     T4 = SIN(DIP)                                              LAMDAS.33
C     ****                                                                LAMDAS.34
      DO I=1,LEN1                                                         LAMDAS.35
       T1(I)=BMOD(I,J)                                                    LAMDAS.36
       T2(I)=9.6489D3*T1(I)                                               LAMDAS.37
       T3(I)=1.7588028D7*T1(I)                                            LAMDAS.38
       T4(I)=DSIN(DIPMAG(I,J))                                            LAMDAS.39
      ENDDO                                                               LAMDAS.40
C     ****                                                                LAMDAS.41
C     ****     V1 = PSI(O2)/M(O2), V2 = PSI(O)/M(O), V3 = PSI2)/M(N2)     LAMDAS.42
C     ****      V6 = TR = 0.5*(TI+TN)                 AT (K+1/2)          LAMDAS.43
C     ****                                                                LAMDAS.44
      NPS1K=NJ+NPS                                                        LAMDAS.45
      NPS2K=NJ+NPS2                                                       LAMDAS.46
      NTIK=NJ+NTI                                                         LAMDAS.47
      NTK=NJ+NT                                                           LAMDAS.48
      DO I=1,LEN2                                                         LAMDAS.49
       V1(I,1)=F(I,NPS1K)/RMASS(1)                                        LAMDAS.50
       V2(I,1)=F(I,NPS2K)/RMASS(2)                                        LAMDAS.51
       V3(I,1)=(1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3)                        LAMDAS.52
       V6(I,1)=0.5*(F(I,NTIK)+F(I,NTK))                                   LAMDAS.53
      ENDDO                                                               LAMDAS.54
C     ****                                                                LAMDAS.55
C     ****     RM = NEW(L,M)                                              LAMDAS.56
C     ****                                                                LAMDAS.57
C     ****     GENERATE NUMERICAL FACTORS                                 LAMDAS.58
C     ****                                                                LAMDAS.59
      CALL N2NEW(V6,RM)                                                   LAMDAS.60
C     ****                                                                LAMDAS.61
C     ****     MULTIPLY BY MAJOR SPECIES NUMBER DENSITIES                 LAMDAS.62
C     ****                                                                LAMDAS.63
      DO L=1,3                                                            LAMDAS.64
       DO I=1,LEN2                                                        LAMDAS.65
        RM(I,1,L,1)=RM(I,1,L,1)*V1(I,1)                                   LAMDAS.66
        RM(I,1,L,2)=RM(I,1,L,2)*V2(I,1)                                   LAMDAS.67
        RM(I,1,L,3)=RM(I,1,L,3)*V3(I,1)                                   LAMDAS.68
       ENDDO                                                              LAMDAS.69
      ENDDO                                                               LAMDAS.70
C     ****                                                                LAMDAS.71
C     ****     V1(L) = SUM(M=1,3) RM1(L,M)    ( K+1/2 )                   LAMDAS.72
C     ****                                                                LAMDAS.73
      DO I=1,LEN2                                                         LAMDAS.74
       V1(I,1)=0.                                                         LAMDAS.75
       V2(I,1)=0.                                                         LAMDAS.76
       V3(I,1)=0.                                                         LAMDAS.77
      ENDDO                                                               LAMDAS.78
      DO M=1,3                                                            LAMDAS.79
       DO I=1,LEN2                                                        LAMDAS.80
        V1(I,1)=V1(I,1)+RM(I,1,1,M)                                       LAMDAS.81
        V2(I,1)=V2(I,1)+RM(I,1,2,M)                                       LAMDAS.82
        V3(I,1)=V3(I,1)+RM(I,1,3,M)                                       LAMDAS.83
       ENDDO                                                              LAMDAS.84
      ENDDO                                                               LAMDAS.85
C     ****                                                                LAMDAS.86
C     ****     RM(1) = N(O2+), RM(2) = N(O+), RM(3) = N(NO+)              LAMDAS.87
C     ****                      ( AT (K+1/2) )                            LAMDAS.88
C     ****                                                                LAMDAS.89
      NO2PK=NJ+NO2P                                                       LAMDAS.90
      NOPK=NJ+NOP                                                         LAMDAS.91
      NNOPK=NNOP                                                          LAMDAS.92
      DO I=1,LEN2                                                         LAMDAS.93
       RM(I,1,1,1)=F(I,NO2PK)                                             LAMDAS.94
       RM(I,1,2,1)=F(I,NOPK)                                              LAMDAS.95
       RM(I,1,3,1)=F(I,NNOPK)                                             LAMDAS.96
      ENDDO                                                               LAMDAS.97
C     ****                                                                LAMDAS.98
C     ****     V6 = N * MBAR            ( K+1/2 )                         LAMDAS.99
C     ****                                                                LAMDAS.100
      NTK=NJ+NT-1                                                         LAMDAS.101
      NMSK=NJ+NMS-1                                                       LAMDAS.102
      DO K=1,KMAX                                                         LAMDAS.103
       NTK=NTK+1                                                          LAMDAS.104
       NMSK=NMSK+1                                                        LAMDAS.105
       DO I=1,LEN1                                                        LAMDAS.106
        V6(I,K)=C(81)*EXPS(K)*.5*(F(I,NMSK)+F(I,NMSK+1))/(C(84)*          LAMDAS.107
     1            F(I,NTK))                                               LAMDAS.108
       ENDDO                                                              LAMDAS.109
      ENDDO                                                               LAMDAS.110
C     ****                                                                LAMDAS.111
C     ****     V1(L) = V1(L)*(N*MBAR)/OMEGAI(L)    ( L=1,3 )  ( K=1/2 )   LAMDAS.112
C     ****                                                                LAMDAS.113
      DO K=1,KMAX                                                         LAMDAS.114
       DO I=1,LEN1                                                        LAMDAS.115
        V1(I,K)=V1(I,K)*V6(I,K)*RMS(1)/T2(I)                              LAMDAS.116
        V2(I,K)=V2(I,K)*V6(I,K)*RMS(2)/T2(I)                              LAMDAS.117
        V3(I,K)=V3(I,K)*V6(I,K)*RMS(3)/T2(I)                              LAMDAS.118
       ENDDO                                                              LAMDAS.119
      ENDDO                                                               LAMDAS.120
C     ****                                                                LAMDAS.121
C     ****     V4 = NU/OMEGA (E)                                          LAMDAS.122
C     ****                                                                LAMDAS.123
      NPS1K=NJ+NPS                                                        LAMDAS.124
      NPS2K=NJ+NPS2                                                       LAMDAS.125
      NTEK=NJ+NTE                                                         LAMDAS.126
      DO I=1,LEN2                                                         LAMDAS.127
       V5(I,1)=DSQRT(F(I,NTEK))                                           LAMDAS.128
       V4(I,1)=V6(I,1)*(2.33D-11*(1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3)*     LAMDAS.129
     1         F(I,NTEK)*(1.-1.21D-4*F(I,NTEK))+1.82D-10*F(I,NPS1K)/      LAMDAS.130
     2         RMASS(1)*V5(I,1)*(1.+3.6D-2*V5(I,1))+8.9D-11*              LAMDAS.131
     3         F(I,NPS2K)/RMASS(2)*V5(I,1)*(1.+5.7D-4*F(I,NTEK)))         LAMDAS.132
      ENDDO                                                               LAMDAS.133
C     ****                                                                LAMDAS.134
C     ****     V4 = NU(EN)/OMEGAE                                         LAMDAS.135
C     ****                                                                LAMDAS.136
      DO K=1,KMAX                                                         LAMDAS.137
       DO I=1,LEN1                                                        LAMDAS.138
        V4(I,K)=V4(I,K)/T3(I)                                             LAMDAS.139
       ENDDO                                                              LAMDAS.140
      ENDDO                                                               LAMDAS.141
C     ****                                                                LAMDAS.142
C     ****     RM2 = PEDERSEN FACTORS                                     LAMDAS.143
C     ****     RM3 = HALL FACTORS                                         LAMDAS.145
C     ****                                                                LAMDAS.146
      DO I=1,LEN2                                                         LAMDAS.147
       RM(I,1,1,2)=V4(I,1)/(1.+V4(I,1)**2)+V1(I,1)/(1.+V1(I,1)**2)        LAMDAS.148
       RM(I,1,2,2)=V4(I,1)/(1.+V4(I,1)**2)+V2(I,1)/(1.+V2(I,1)**2)        LAMDAS.149
       RM(I,1,3,2)=V4(I,1)/(1.+V4(I,1)**2)+V3(I,1)/(1.+V3(I,1)**2)        LAMDAS.140
       RM(I,1,1,3)=1./(1.+V4(I,1)**2)-1./(1+V1(I,1)**2)                   LAMDAS.150
       RM(I,1,2,3)=1./(1.+V4(I,1)**2)-1./(1+V2(I,1)**2)                   LAMDAS.151
       RM(I,1,3,3)=1./(1.+V4(I,1)**2)-1./(1+V3(I,1)**2)                   LAMDAS.152
      ENDDO                                                               LAMDAS.153
C     ****                                                                LAMDAS.154
C     ****     V1 = SUM(L=1,3) PEDERSEN FACTORS * ION DENSITIES           LAMDAS.155
C     ****     V2 = SUM(L=1,3) HALL FACTORS * ION DENSITIES               LAMDAS.156
C     ****                                                                LAMDAS.157
      DO I=1,LEN2                                                         LAMDAS.158
       V1(I,1)=0.                                                         LAMDAS.159
       V2(I,1)=0.                                                         LAMDAS.160
      ENDDO                                                               LAMDAS.161
      DO L=1,3                                                            LAMDAS.189   
        DO K=1,KMAX                                                       LAMDAS.190
          DO I=1,LEN1                                                     LAMDAS.191   
            V1(I,K)=V1(I,K)+RM(I,K,L,2)*RM(I,K,L,1)                       LAMDAS.192   
            V2(I,K)=V2(I,K)+RM(I,K,L,3)*RM(I,K,L,1)                       LAMDAS.193   
          ENDDO                                                           LAMDAS.194
        ENDDO                                                             LAMDAS.195
      ENDDO                                                               LAMDAS.196
C     ****                                                                LAMDAS.168
C     ****     SET LXX, LYY, LXY                                          LAMDAS.169
C     ****                                                                LAMDAS.170
      DO K=1,KMAX                                                         LAMDAS.171
       DO I=1,LEN1                                                        LAMDAS.172
        V3(I,K)=V1(I,K)*T1(I)*1.D-1*QE*C(85)/V6(I,K)                      LAMDAS.173
        V4(I,K)=V3(I,K)*T4(I)**2                                          LAMDAS.174
        V5(I,K)=V2(I,K)*T1(I)*1.D-1*QE*C(85)/V6(I,K)                      LAMDAS.175
       ENDDO                                                              LAMDAS.176
      ENDDO                                                               LAMDAS.177
      NLXXK=NLXX+1                                                        LAMDAS.207   
      NLYYK=NLYY+1                                                        LAMDAS.208   
      NLXYK=NLXY+1                                                        LAMDAS.209   
      DO K=2,KMAX                                                         LAMDAS.210
        DO I=1,LEN1                                                       LAMDAS.211
          F(I,NLXXK)=DSQRT(DABS(V3(I,K-1)*V3(I,K)))                       LAMDAS.212   
          F(I,NLYYK)=DSQRT(DABS(V4(I,K-1)*V4(I,K)))                       LAMDAS.213   
          F(I,NLXYK)=DSQRT(DABS(V5(I,K-1)*V5(I,K)))                       LAMDAS.214   
        ENDDO                                                             LAMDAS.215
        NLXXK=NLXXK+1                                                     LAMDAS.216
        NLYYK=NLYYK+1                                                     LAMDAS.217
        NLXYK=NLXYK+1                                                     LAMDAS.218
      ENDDO                                                               LAMDAS.219
C     ****                                                                LAMDAS.186
C     ****     BOUNDARIES                                                 LAMDAS.187
C     ****                                                                LAMDAS.188
      NLXXK=NLXX                                                          LAMDAS.189
      NLYYK=NLYY                                                          LAMDAS.190
      NLXYK=NLXY                                                          LAMDAS.191
      DO I=1,LEN1                                                         LAMDAS.192
       F(I,NLXXK)=DSQRT(V3(I,1)**3/V3(I,2))                               LAMDAS.193
       F(I,NLYYK)=DSQRT(V4(I,1)**3/V4(I,2))                               LAMDAS.194
       F(I,NLXYK)=DSQRT(V5(I,1)**3/V5(I,2))                               LAMDAS.195
       F(I,NLXXK+KMAX)=DSQRT(DABS(V3(I,KMAX)**3/V3(I,KMAXM1)))            LAMDAS.196
       F(I,NLYYK+KMAX)=DSQRT(DABS(V4(I,KMAX)**3/V4(I,KMAXM1)))            LAMDAS.197
       F(I,NLXYK+KMAX)=DSQRT(DABS(V5(I,KMAX)**3/V5(I,KMAXM1)))            LAMDAS.198
      ENDDO                                                               LAMDAS.199
      NLXYK=NLXY-1                                                        LAMDAS.200
      DO K=1,KMAXP1                                                       LAMDAS.201
       NLXYK=NLXYK+1                                                      LAMDAS.202
       DO I=1,LEN1                                                        LAMDAS.203
        F(I,NLXYK)=F(I,NLXYK)*T4(I)                                       LAMDAS.204
       ENDDO                                                              LAMDAS.205
      ENDDO                                                               LAMDAS.206
C     ****                                                                LAMDAS.207
C     ****     COPY SIGMA1, SIGMA2, Z, H, U, V AND W TO COMMON/DYNAMO/    LAMDAS.208
C     ****                                                                LAMDAS.209
      NZK=NJ+NZ-1                                                         LAMDAS.210
      NTK=NJ+NT-1                                                         LAMDAS.211
      NMSK=NJ+NMS-1                                                       LAMDAS.212
      NUK=NJ+NU-1                                                         LAMDAS.213
      NVK=NJ+NV-1                                                         LAMDAS.214
      NWK=NJ+NW-1                                                         LAMDAS.215
      DO K=1,KMAX                                                         LAMDAS.216
       NZK=NZK+1                                                          LAMDAS.217
       NTK=NTK+1                                                          LAMDAS.218
       NMSK=NMSK+1                                                        LAMDAS.219
       NUK=NUK+1                                                          LAMDAS.220
       NVK=NVK+1                                                          LAMDAS.221
       NWK=NWK+1                                                          LAMDAS.222
       DO I=1,IMAX+1                                                      LAMDAS.223
        SIGMA1(I,J,K)=V1(I+2,K)*1.d10*QE/T1(I+2)                          LAMDAS.224
        SIGMA2(I,J,K)=V2(I+2,K)*1.d10*QE/T1(I+2)                          LAMDAS.225
        Z(I,J,K)=F(I+2,NZK)                                               LAMDAS.226
        H=C(57)*F(I+2,NTK)/(.5d0*(F(I+2,NMSK)+F(I+2,NMSK+1))*C(54))       LAMDAS.227
        U(I,J,K)=F(I+2,NUK)                                               LAMDAS.229
        V(I,J,K)=F(I+2,NVK)                                               LAMDAS.230
        W(I,J,K)=.5*(F(I+2,NWK)+F(I+2,NWK+1))*H                           LAMDAS.231
       ENDDO                                                              LAMDAS.232
      ENDDO                                                               LAMDAS.233
      RETURN                                                              LAMDAS.238
      END                                                                 LAMDAS.239
C                                                                         LAMDAS.240
*DK LSQDSQ                                                                LSQDSQ.1
      SUBROUTINE N2LSQDSQ(JJ,PSIJP,PSIJ,PSIJM,S,LENX)                     LSQDSQ.2
CcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccC LSQDSQ.3
c  Subroutine LSQDSQ calculates L**2 DEL**2 (PSI) for horizontal dif-   c LSQDSQ.4
c  fusion terms.                                                        c LSQDSQ.5
c  It is adapted from TIGCM and rewritten by Wenbin Wang.               c LSQDSQ.6
c                                                            01/10/95   c LSQDSQ.7
CcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccC LSQDSQ.8
C     ****                                                                LSQDSQ.9
C     ****                   SUBROUTINE TO CALCULATE L**2DEL**2(PSI)      LSQDSQ.10
C     ****                        JJ IS THE CURRENT LATITUDE LINE,        LSQDSQ.11
C     ****                        PSIJP,PSIJ,PSIJM ARE THE 3 APPROPRIATE  LSQDSQ.12
C     ****                        LATITUDE LINES J+1,J,J-1,  AND          LSQDSQ.13
C     ****                        S IS THE ARRAY FOR THE RESULT.          LSQDSQ.14
C     ****                                                                LSQDSQ.15
      include 'n2param.h'                                                 LSQDSQ.16
      include 'n2const.h'                                                 LSQDSQ.18
      include 'index.h'                                                   LSQDSQ.19
      DIMENSION PSIJP(1),PSIJ(1),PSIJM(1),S(1)                            LSQDSQ.21
C     ****                                                                LSQDSQ.22
C     ****                   LONG AND LAT LENGTH FUNCTIONS                LSQDSQ.23
C     ****                   FLENL = A*ABS(COS(JJ))*PI/KUT(JJ)            LSQDSQ.24
C     ****                   FLENP = A*DPHI                               LSQDSQ.25
C     ****                                                                LSQDSQ.26
      FLENL=C(51)*DABS(CS(JJ))*C(1)                                       LSQDSQ.27
      FLENP=C(51)*C(2)                                                    LSQDSQ.28
      CON1=FLENL*FLENL/(C(51)*CS(JJ)*C(1))**2                             LSQDSQ.29
      CON2=FLENP*FLENP/((C(51)*C(2))**2*CS(JJ))                           LSQDSQ.30
C     ****                                                                LSQDSQ.31
C     ****                   S = L*L/(A*CS(JJ)*DLAMBDA)**2*(PSI(I+1)-     LSQDSQ.32
C     ****                       2*PSI(I) + PSI(I-1))                     LSQDSQ.33
C     ****                                                                LSQDSQ.34
      DO I=2,LENX                                                         LSQDSQ.35
        S(I)=CON1*(PSIJ(I+1)-2.* PSIJ(I)+PSIJ(I-1))                       LSQDSQ.36
      ENDDO                                                               LSQDSQ.37
C     ****                                                                LSQDSQ.38
C     ****                   DPSIP=(PSI(J+1)-PSI(J))*.5*(CS(J+1)+CS(J))   LSQDSQ.39
C     ****                   DPSIM=(PSI(J)-PSI(J-1))*.5*(CS(J)+CS(J-1))   LSQDSQ.40
C     ****                   DPSI = (DPSIP-DPSIM)*(LP**2/                 LSQDSQ.41
C     ****                          (A*A*CS(J)*DPHI*2)                    LSQDSQ.42
C     ****                                                                LSQDSQ.43
      DO I=2,LENX                                                         LSQDSQ.44
        DPSIP=(PSIJP(I)-PSIJ(I))*0.5*(CS(JJ+1)+CS(JJ))                    LSQDSQ.45
        DPSIM=(PSIJ(I)-PSIJM(I))*0.5*(CS(JJ)+CS(JJ-1))                    LSQDSQ.46
        DPSI=CON2*(DPSIP-DPSIM)                                           LSQDSQ.47
        S(I)=S(I)+DPSI                                                    LSQDSQ.53
      ENDDO                                                               LSQDSQ.48
      RETURN                                                              LSQDSQ.55
      END                                                                 LSQDSQ.56
C                                                                         LSQDSQ.57
*DK MAGFIELD                                                            MAGFIELD.1
      SUBROUTINE N2MAGFIELD(LEVEL)                                      MAGFIELD.2
C     ****                                                              MAGFIELD.3
C     ****     SET UP VERSIONS OF /TRGM/ AND /MAGFLD/ CALCULATED        MAGFIELD.4
C     ****       FROM TRUE FIELD AVAILABLE IN /FIELD/                   MAGFIELD.5
C     ****                                                              MAGFIELD.6
      INCLUDE 'n2param.h'                                               MAGFIELD.7
      INCLUDE 'n2const.h'                                               MAGFIELD.8
      INCLUDE 'n2nestg.h'                                               MAGFIELD.9
      INCLUDE 'nestcnt.h'                                               MAGFIELD.10
      COMMON/N2MAGFLD/BX(IMX,JMX),BY(IMX,JMX),BZ(IMX,JMX),              MAGFIELD.11
     1                BMOD2(IMX,JMX)                                    MAGFIELD.12
      COMMON/N2TRGM/RLATM(IMX,JMX),RLONM(IMX,JMX),DIPMAG(IMX,JMX),      MAGFIELD.13
     1              DECMAG(IMX,JMX),SNDEC(IMX,JMX),CSDEC(IMX,JMX),      MAGFIELD.14
     2              SN2DEC(IMX,JMX),SNCSDC(IMX,JMX),DUMDUM(JMX,3)       MAGFIELD.15
      COMMON/N2TRGM1/RLATMR(IMX,JMX),RLONMR(IMX,JMX)                    MAGFIELD.16
C     ****                                                              MAGFIELD.17
C     ****     INTERPOLATE MAGNETIC FIELD PARAMETERS FOR NESTED GRID    MAGFIELD.18
C     ****                                                              MAGFIELD.19
      CALL N2MAGINTER(BX,1,JMX,1,IMX,LEVEL,1)                           MAGFIELD.20
      CALL N2MAGINTER(BY,1,JMX,1,IMX,LEVEL,2)                           MAGFIELD.21
      CALL N2MAGINTER(BZ,1,JMX,1,IMX,LEVEL,3)                           MAGFIELD.22
      CALL N2MAGINTER(BMOD2,1,JMX,1,IMX,LEVEL,4)                        MAGFIELD.23
      CALL N2MAGINTER(RLATM,1,JMX,1,IMX,LEVEL,5)                        MAGFIELD.24
      CALL N2MAGINTER(RLONM,1,JMX,1,IMX,LEVEL,6)                        MAGFIELD.25
      CALL N2MAGINTER(DIPMAG,1,JMX,1,IMX,LEVEL,7)                       MAGFIELD.26
      CALL N2MAGINTER(DECMAG,1,JMX,1,IMX,LEVEL,8)                       MAGFIELD.27
      CALL N2MAGINTER(SNDEC,1,JMX,1,IMX,LEVEL,9)                        MAGFIELD.28
      CALL N2MAGINTER(CSDEC,1,JMX,1,IMX,LEVEL,10)                       MAGFIELD.29
      CALL N2MAGINTER(SN2DEC,1,JMX,1,IMX,LEVEL,11)                      MAGFIELD.30
      CALL N2MAGINTER(SNCSDC,1,JMX,1,IMX,LEVEL,12)                      MAGFIELD.31
      CALL N2MAGINTER(RLATMR,1,JMX,1,IMX,LEVEL,13)                      MAGFIELD.32
      CALL N2MAGINTER(RLATMR,1,JMX,1,IMX,LEVEL,14)                      MAGFIELD.33
C     ****                                                              MAGFIELD.34
C     ****     INTERPOLATE MAGNETIC POLE PARAMETERS FOR NESTED GRID     MAGFIELD.35
C     ****                                                              MAGFIELD.36
      CALL N2DUMINTER(DUMDUM,1,JMX,LEVEL)                               MAGFIELD.37
      RETURN                                                            MAGFIELD.38
      END                                                               MAGFIELD.39
C                                                                       MAGFIELD.40
*DK MAGINTER                                                            MAGINTER.1
      SUBROUTINE N2MAGINTER(W,J1,JM,I1,IM,LEVEL,INDEX)                  MAGINTER.2
C     ****                                                              MAGINTER.3
C     ****     INTERPOLATION OF FIELDS OF MAGNETIC FIELD FOR            MAGINTER.4
C     ****     NESTED GRIDS                                             MAGINTER.5
C     ****                                                              MAGINTER.6
      INCLUDE 'n1param.h'                                               MAGINTER.7
      INCLUDE 'n1const.h'                                               MAGINTER.8
      INCLUDE 'nestcnt.h'                                               MAGINTER.9
      INCLUDE 'n2nestg.h'                                               MAGINTER.10
      COMMON/N1MAGFLD/BX(IMX,JMX),BY(IMX,JMX),BZ(IMX,JMX),              MAGINTER.11
     1                BMOD2(IMX,JMX)                                    MAGINTER.12
      COMMON/N1TRGM/RLATM(IMX,JMX),RLONM(IMX,JMX),DIPMAG(IMX,JMX),      MAGINTER.13
     1              DECMAG(IMX,JMX),SNDEC(IMX,JMX),CSDEC(IMX,JMX),      MAGINTER.14
     2              SN2DEC(IMX,JMX),SNCSDC(IMX,JMX),DUMDUM(JMX,3)       MAGINTER.15
      COMMON/N1TRGM1/RLATMR(IMX,JMX),RLONMR(IMX,JMX)                    MAGINTER.16
      DIMENSION W(I1:IM,J1:JM),S(IMX,JMX)                               MAGINTER.17
C     ****                                                              MAGINTER.18
C     ****     SPECIFY FIELD TO INTERPOLATE                             MAGINTER.19
C     ****                                                              MAGINTER.20
      IF(INDEX.EQ.1)THEN                                                MAGINTER.21
       DO J=1,JMX                                                       MAGINTER.22
        DO I=1,IMX                                                      MAGINTER.23
         S(I,J)=BX(I,J)                                                 MAGINTER.24
        ENDDO                                                           MAGINTER.25
       ENDDO                                                            MAGINTER.26
      ELSE IF(INDEX.EQ.2)THEN                                           MAGINTER.27
       DO J=1,JMX                                                       MAGINTER.28
        DO I=1,IMX                                                      MAGINTER.29
         S(I,J)=BY(I,J)                                                 MAGINTER.30
        ENDDO                                                           MAGINTER.31
       ENDDO                                                            MAGINTER.32
      ELSE IF(INDEX.EQ.3)THEN                                           MAGINTER.33
       DO J=1,JMX                                                       MAGINTER.34
        DO I=1,IMX                                                      MAGINTER.35
         S(I,J)=BZ(I,J)                                                 MAGINTER.36
        ENDDO                                                           MAGINTER.37
       ENDDO                                                            MAGINTER.38
      ELSE IF(INDEX.EQ.4)THEN                                           MAGINTER.39
       DO J=1,JMX                                                       MAGINTER.40
        DO I=1,IMX                                                      MAGINTER.41
         S(I,J)=BMOD2(I,J)                                              MAGINTER.42
        ENDDO                                                           MAGINTER.43
       ENDDO                                                            MAGINTER.44
      ELSE IF(INDEX.EQ.5)THEN                                           MAGINTER.45
       DO J=1,JMX                                                       MAGINTER.46
        DO I=1,IMX                                                      MAGINTER.47
         S(I,J)=RLATM(I,J)                                              MAGINTER.48
        ENDDO                                                           MAGINTER.49
       ENDDO                                                            MAGINTER.50
      ELSE IF(INDEX.EQ.6)THEN                                           MAGINTER.51
       DO J=1,JMX                                                       MAGINTER.52
        DO I=1,IMX                                                      MAGINTER.53
         S(I,J)=RLONM(I,J)                                              MAGINTER.54
        ENDDO                                                           MAGINTER.55
       ENDDO                                                            MAGINTER.56
      ELSE IF(INDEX.EQ.7)THEN                                           MAGINTER.57
       DO J=1,JMX                                                       MAGINTER.58
        DO I=1,IMX                                                      MAGINTER.59
         S(I,J)=DIPMAG(I,J)                                             MAGINTER.60
        ENDDO                                                           MAGINTER.61
       ENDDO                                                            MAGINTER.62
      ELSE IF(INDEX.EQ.8)THEN                                           MAGINTER.63
       DO J=1,JMX                                                       MAGINTER.64
        DO I=1,IMX                                                      MAGINTER.65
         S(I,J)=DECMAG(I,J)                                             MAGINTER.66
        ENDDO                                                           MAGINTER.67
       ENDDO                                                            MAGINTER.68
      ELSE IF(INDEX.EQ.9)THEN                                           MAGINTER.69
       DO J=1,JMX                                                       MAGINTER.70
        DO I=1,IMX                                                      MAGINTER.71
         S(I,J)=SNDEC(I,J)                                              MAGINTER.72
        ENDDO                                                           MAGINTER.73
       ENDDO                                                            MAGINTER.74
      ELSE IF(INDEX.EQ.10)THEN                                          MAGINTER.75
       DO J=1,JMX                                                       MAGINTER.76
        DO I=1,IMX                                                      MAGINTER.77
         S(I,J)=CSDEC(I,J)                                              MAGINTER.78
        ENDDO                                                           MAGINTER.79
       ENDDO                                                            MAGINTER.80
      ELSE IF(INDEX.EQ.11)THEN                                          MAGINTER.81
       DO J=1,JMX                                                       MAGINTER.82
        DO I=1,IMX                                                      MAGINTER.83
         S(I,J)=SN2DEC(I,J)                                             MAGINTER.84
        ENDDO                                                           MAGINTER.85
       ENDDO                                                            MAGINTER.86
      ELSE IF(INDEX.EQ.12)THEN                                          MAGINTER.87
       DO J=1,JMX                                                       MAGINTER.88
        DO I=1,IMX                                                      MAGINTER.89
         S(I,J)=SNCSDC(I,J)                                             MAGINTER.90
        ENDDO                                                           MAGINTER.91
       ENDDO                                                            MAGINTER.92
      ELSE IF(INDEX.EQ.13)THEN                                          MAGINTER.93
       DO J=1,JMX                                                       MAGINTER.94
        DO I=1,IMX                                                      MAGINTER.95
         S(I,J)=RLATMR(I,J)                                             MAGINTER.96
        ENDDO                                                           MAGINTER.97
       ENDDO                                                            MAGINTER.98
      ELSE IF(INDEX.EQ.14)THEN                                          MAGINTER.99
       DO J=1,JMX                                                       MAGINTER.100
        DO I=1,IMX                                                      MAGINTER.101
         S(I,J)=RLONMR(I,J)                                             MAGINTER.102
        ENDDO                                                           MAGINTER.103
       ENDDO                                                            MAGINTER.104
      ENDIF                                                             MAGINTER.105
      RATIO=DBLE(NESTRI(LEVEL))                                         MAGINTER.106
      DO J=1,JNX                                                        MAGINTER.107
C      ****                                                             MAGINTER.108
C      ****     FIRST LINE IN LATITUDE                                  MAGINTER.109
C      ****                                                             MAGINTER.110
       IF(J.EQ.1)THEN                                                   MAGINTER.111
        DO I=1,INX                                                      MAGINTER.112
         II=NESTRI(LEVEL)*(I-1)+1                                       MAGINTER.113
         IC=NESTI1(LEVEL)+I-1                                           MAGINTER.114
         JJ=NESTJ1(LEVEL)+J-1                                           MAGINTER.115
         IF(I.LT.INX)THEN                                               MAGINTER.116
          W(II,J)=S(IC,JJ)                                              MAGINTER.117
          DO L=1,NESTRI(LEVEL)-1                                        MAGINTER.118
           IL=II+L                                                      MAGINTER.119
           W(IL,J)=S(IC,JJ)+DBLE(L)*(S(IC+1,JJ)-S(IC,JJ))/RATIO         MAGINTER.120
          ENDDO                                                         MAGINTER.121
         ELSE                                                           MAGINTER.122
          W(II,J)=S(IC,JJ)                                              MAGINTER.123
         ENDIF                                                          MAGINTER.124
        ENDDO                                                           MAGINTER.125
       ELSE                                                             MAGINTER.126
C       ****                                                            MAGINTER.127
C       ****     NEXT LINE IN LATITUDE                                  MAGINTER.128
C       ****                                                            MAGINTER.129
        JJ=NESTJ1(LEVEL)+J-1                                            MAGINTER.130
        J2=NESTRI(LEVEL)*(J-1)+1                                        MAGINTER.131
        J1=NESTRI(LEVEL)*(J-2)+1                                        MAGINTER.132
        DO I=1,INX                                                      MAGINTER.133
         II=NESTRI(LEVEL)*(I-1)+1                                       MAGINTER.134
         IC=NESTI1(LEVEL)+I-1                                           MAGINTER.135
         IF(I.LT.INX)THEN                                               MAGINTER.136
          W(II,J2)=S(IC,JJ)                                             MAGINTER.137
          DO L=1,NESTRI(LEVEL)-1                                        MAGINTER.138
           IL=II+L                                                      MAGINTER.139
           W(IL,J2)=S(IC,JJ)+DBLE(L)*(S(IC+1,JJ)-S(IC,JJ))/RATIO        MAGINTER.140
          ENDDO                                                         MAGINTER.141
         ELSE                                                           MAGINTER.142
          W(II,J2)=S(IC,JJ)                                             MAGINTER.143
         ENDIF                                                          MAGINTER.144
        ENDDO                                                           MAGINTER.145
C       ****                                                            MAGINTER.146
C       ****     CALCULATE LATITUDINAL LINES IN BETWEEN                 MAGINTER.147
C       ****                                                            MAGINTER.148
        DO I=1,NNX                                                      MAGINTER.149
         DO L=1,NESTRI(LEVEL)-1                                         MAGINTER.150
          W(I,J2-L)=W(I,J2)-DBLE(L)*(W(I,J2)-W(I,J1))/RATIO             MAGINTER.151
         ENDDO                                                          MAGINTER.152
        ENDDO                                                           MAGINTER.153
       ENDIF                                                            MAGINTER.154
      ENDDO                                                             MAGINTER.155
      RETURN                                                            MAGINTER.156
      END                                                               MAGINTER.157
C                                                                       MAGINTER.158
*DK MINOR                                                                  MINOR.1    
      SUBROUTINE N2MINOR(NX,NXNM,RMX,PHIX,ALFAX,IBND,IBNDB,LEVEL,NTIME)    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 'n2param.h'                                                  MINOR.34   
      include 'start.h'                                                    MINOR.35   
      include 'n2cvscr.h'                                                  MINOR.36   
      include 'n2const.h'                                                  MINOR.37   
      include 'index.h'                                                    MINOR.38  
      include 'buffe.h'                                                    MINOR.39   
      include 'n2phycs.h'                                                  MINOR.40   
      include 'n2array.h'                                                  MINOR.41
      include 'nestcnt.h'                                                  MINOR.42
      INCLUDE 'n2cpbnd.h' 
      DIMENSION PHIX(3),PHI(2,3)                                           MINOR.43   
      DATA PHI/0.,0.673,1.35,0.,1.11,0.769/,TAU/1.86D+3/,T00/273./,        MINOR.44   
C     ****                                                                 MINOR.45   
C     ****     VALUE OF 'SMALL' FOR MINOR                                  MINOR.46   
C     ****                                                                 MINOR.47   
     1SMALL/1.D-12/                                                        MINOR.48   
C     ****                                                                 MINOR.50   
C     ****     S13 = HORIZONAL ADVECTION                                   MINOR.51
C     ****                                                                 MINOR.52 
      IF(J.NE.2.AND.J.NE.JMAX-1)THEN                                       MINOR.53
        CALL N2ADVEC(NX,S13)                                               MINOR.54
        CALL N2ADVEC2(NX,S13)                                              MINOR.55
      ELSE                                                                 MINOR.56
        CALL N2ADVEC3(NX,S13)                                              MINOR.57
      ENDIF                                                                MINOR.58
      CALL N2FILTER2(S13,J,KMAX,LEVEL)
C     ****                                                                 MINOR.64
C     ****     S14=SX/N(X)(K+1/2),  S15=S0(K+1/2)                          MINOR.65
C     ****                                                                 MINOR.66  
      DO K=1,KMAX                                                          MINOR.67
        DO I=1,LEN1                                                        MINOR.68
          S15(I,K)=S2(I,K)                                                 MINOR.69 
          S14(I,K)=S1(I,K)                                                 MINOR.70 
        ENDDO                                                              MINOR.71
      ENDDO                                                                MINOR.72
C     ****                                                                 MINOR.73
C     ****     T4 = PS1(-1/2), T5 = PS2(-1/2), T6 = MBAR(-1/2)             MINOR.74
C     ****                                                                 MINOR.75  
      NPS1K=NJ+NPS                                                         MINOR.76  
      NPS2K=NPS1K+KMAXP1                                                   MINOR.77   
      DO I=1,LEN1                                                          MINOR.78   
        T7(I)=T4(I)                                                        MINOR.79   
        T4(I)=B(I,1,1)*F(I,NPS1K)+B(I,1,2)*F(I,NPS2K)+FB(I,1)              MINOR.80   
        T5(I)=B(I,2,1)*F(I,NPS1K)+B(I,2,2)*F(I,NPS2K)+FB(I,2)              MINOR.81   
        T6(I)=1./(T4(I)/RMASS(1)+T5(I)/RMASS(2)+(1.-T4(I)-T5(I))/          MINOR.82
     1        RMASS(3))                                                    MINOR.83
      ENDDO                                                                MINOR.84
C     ****                                                                 MINOR.85
C     ****     S12 = MBAR(K+1/2)                                           MINOR.86
C     ****                                                                 MINOR.87   
      DO K=1,KMAXP1                                                        MINOR.88
        DO I=1,LEN1                                                        MINOR.89   
          S12(I,K)=1./(F(I,NPS1K)/RMASS(1)+F(I,NPS2K)/RMASS(2)             MINOR.90
     1             +(1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3))                   MINOR.91   
        ENDDO                                                              MINOR.92
        NPS1K=NPS1K+1                                                      MINOR.93
        NPS2K=NPS2K+1                                                      MINOR.94
      ENDDO                                                                MINOR.95
C     ****                                                                 MINOR.96
C     ****     S11 = MBAR(K), S10 = DM/DZ(K), S9 = PS2(K),                 MINOR.97 
C     ****     S8 = PS1(K), S7 = DPS2/DZ(K), S6 = DPS1/DZ(K)               MINOR.98  
C     ****     LOWER BOUNDARY                                              MINOR.99
C     ****                                                                 MINOR.100
      NPS1K=NJ+NPS                                                         MINOR.101
      NPS2K=NPS1K+KMAXP1                                                   MINOR.102
      DO I=1,LEN1                                                          MINOR.103
        S11(I,1)=.5*(T6(I)+S12(I,1))                                       MINOR.104 
        S10(I,1)=(S12(I,1)-T6(I))/C(3)                                     MINOR.105  
        S9(I,1)=.5*(T5(I)+F(I,NPS2K))                                      MINOR.106  
        S8(I,1)=.5*(T4(I)+F(I,NPS1K))                                      MINOR.107
        S7(I,1)=(F(I,NPS2K)-T5(I))/C(3)                                    MINOR.108 
        S6(I,1)=(F(I,NPS1K)-T4(I))/C(3)                                    MINOR.109 
        T4(I)=T7(I)                                                        MINOR.110 
      ENDDO                                                                MINOR.111
C     ****                                                                 MINOR.112
C     ****     LEVELS K=2,KMAXP1                                           MINOR.113
C     ****                                                                 MINOR.114 
      NPS1K=NJ+NPS+1                                                       MINOR.115
      NPS2K=NPS1K+KMAXP1                                                   MINOR.116
      DO K=2,KMAXP1                                                        MINOR.117
        DO I=1,LEN1                                                        MINOR.118 
          S11(I,K)=.5*(S12(I,K)+S12(I,K-1))                                MINOR.119
          S10(I,K)=(S12(I,K)-S12(I,K-1))/C(3)                              MINOR.120
          S9(I,K)=.5*(F(I,NPS2K)+F(I,NPS2K-1))                             MINOR.121
          S8(I,K)=.5*(F(I,NPS1K)+F(I,NPS1K-1))                             MINOR.122
          S7(I,K)=(F(I,NPS2K)-F(I,NPS2K-1))/C(3)                           MINOR.123
          S6(I,K)=(F(I,NPS1K)-F(I,NPS1K-1))/C(3)                           MINOR.124 
        ENDDO                                                              MINOR.125
        NPS1K=NPS1K+1                                                      MINOR.126
        NPS2K=NPS2K+1                                                      MINOR.127
      ENDDO                                                                MINOR.128
C     ****                                                                 MINOR.129
C     ****     S5=T(TOT,K)                                                 MINOR.130 
C     ****     LOWER AND UPPER BOUNDARIES                                  MINOR.131
C     ****                                                                 MINOR.132 
      NTK=NJ+NT+KMAX                                                       MINOR.133 
        DO I=1,LEN1                                                        MINOR.134 
        S5(I,1)=F(I,NTK)                                                   MINOR.135 
        S5(I,KMAXP1)=F(I,NTK-1)                                            MINOR.136  
      ENDDO                                                                MINOR.137
C     ****                                                                 MINOR.138  
C     ****     LEVELS K=2,KMAX                                             MINOR.139
C     ****                                                                 MINOR.140  
      NTK=NJ+NT                                                            MINOR.141  
      DO K=2,KMAX                                                          MINOR.142  
        NTK=NTK+1                                                          MINOR.143  
        DO I=1,LEN1                                                        MINOR.144  
          S5(I,K)=.5*(F(I,NTK)+F(I,NTK-1))                                 MINOR.145  
        ENDDO                                                              MINOR.146  
      ENDDO                                                                MINOR.147
C     ****                                                                 MINOR.148
C     ****     EVALUATE ALFA12, ALFA21, ALFAM1, ALFAM2                     MINOR.149
C     ****                                                                 MINOR.150   
      ALFA12=PHI(1,2)-PHI(1,3)                                             MINOR.151   
      ALFA21=PHI(2,1)-PHI(2,3)                                             MINOR.152   
      ALFAX1=PHIX(1)-PHIX(3)                                               MINOR.153   
      ALFAX2=PHIX(2)-PHIX(3)                                               MINOR.154   
C     ****                                                                 MINOR.155
C     ****     S15=(S0*MX/NMBAR)(K+1/2)                                    MINOR.156
C     ****                                                                 MINOR.157   
      NTK=NJ+NT-1                                                          MINOR.158   
      DO K=1,KMAX                                                          MINOR.159   
        NTK=NTK+1                                                          MINOR.160   
        DO I=1,LEN1                                                        MINOR.161   
          S15(I,K)=S15(I,K)*RMX*C(84)*F(I,NTK)/(C(81)*                     MINOR.162   
     1             EXPS(K)*S12(I,K))                                       MINOR.163   
        ENDDO                                                              MINOR.164
      ENDDO                                                                MINOR.165
C     ****                                                                 MINOR.166   
C     ****     S1 = ALFA(1,1,K), S2 = ALFA(1,2,K),                         MINOR.167   
C     ****     S2 = ALFA(2,1,K), S4 = ALFA(2,2,K)                          MINOR.168   
C     ****                                                                 MINOR.169
      DO K=1,KMAXP1                                                        MINOR.170
        DO I=1,LEN1                                                        MINOR.171   
          S1(I,K)=-(PHI(1,3)+ALFA12*S9(I,K))                               MINOR.172   
          S2(I,K)=ALFA12*S8(I,K)                                           MINOR.173   
          S3(I,K)=ALFA21*S9(I,K)                                           MINOR.174   
          S4(I,K)=-(PHI(2,3)+ALFA21*S8(I,K))                               MINOR.175
C         ****                                                             MINOR.176
C         ****     S12=EX(K)                                               MINOR.177   
C         ****                                                             MINOR.178
          S12(I,K)=((ALFAX1*S4(I,K)-ALFAX2*S3(I,K))*(S6(I,K)-              MINOR.179
     1             (1.-(RMASS(1)+S10(I,K))/S11(I,K))*S8(I,K))+             MINOR.180   
     2             (ALFAX2*S1(I,K)-ALFAX1*S2(I,K))*(S7(I,K)-(1.-           MINOR.181
     3             (RMASS(2)+S10(I,K))/S11(I,K))*S9(I,K)))/                MINOR.182   
     4             (S1(I,K)*S4(I,K)-S2(I,K)*S3(I,K))+1.-(RMX+              MINOR.183
     5             S10(I,K))/S11(I,K)                                      MINOR.184
C         ****                                                             MINOR.185   
C         ****     S10 = (DM/DZ)/MBAR                                      MINOR.186   
C         ****                                                             MINOR.187
          S10(I,K)=S10(I,K)/S11(I,K)                                       MINOR.188
C         ****                                                             MINOR.189   
C         ****     S11 = AX(K)                                             MINOR.190
C         ****                                                             MINOR.191   
          S11(I,K)=-S11(I,K)/(TAU*RMASS(3))*(T00/S5(I,K))**0.25/           MINOR.192
     1              (PHIX(3)+ALFAX1*S8(I,K)+ALFAX2*S9(I,K))                MINOR.193   
        ENDDO                                                              MINOR.194
      ENDDO                                                                MINOR.195
C     ****                                                                 MINOR.196
C     ****     S12=EX-ALFAX*D/DS(LN(T(TOT))  (THERMAL DIFFUSION TERM)      MINOR.197
C     ****                                                                 MINOR.198   
      DO K=2,KMAX                                                          MINOR.199
        DO I=1,LEN1                                                        MINOR.200   
          S12(I,K)=S12(I,K)-ALFAX*(S5(I,K+1)-S5(I,K-1))/(2.*C(3)           MINOR.201
     1       *S5(I,K))                                                     MINOR.202   
        ENDDO                                                              MINOR.203   
      ENDDO                                                                MINOR.204
C     ****                                                                 MINOR.205
C     ****     LOWER BOUNDARY AND UPPER BOUNDARY                           MINOR.206
C     ****                                                                 MINOR.207   
      DO I=1,LEN1                                                          MINOR.208   
        S12(I,1)=S12(I,1)-ALFAX*(S5(I,2)-S5(I,1))/(C(3)*S5(I,1))           MINOR.209   
      ENDDO                                                                MINOR.210   
      DO I=1,LEN1                                                          MINOR.211   
        S12(I,KMAXP1)=S12(I,KMAXP1)-ALFAX*(S5(I,KMAXP1)                    MINOR.212
     1                -S5(I,KMAX))/(C(3)*S5(I,KMAXP1))                     MINOR.213   
      ENDDO                                                                MINOR.214
C     ****                                                                 MINOR.215   
C     ****     T7=DFACT                                                    MINOR.216
C     ****                                                                 MINOR.217   
      DO I=1,LEN1                                                          MINOR.218   
        T7(I)=1.                                                           MINOR.219   
      ENDDO                                                                MINOR.220   
      IF(ICOMP.EQ.1)CALL N2DFACT(T7,J,IMAX,LEVEL)                          MINOR.221
C     ****                                                                 MINOR.222   
C     ****     SHAPIRO SMOOTHER,   S10=NXNM                                MINOR.223
C     ****                                                                 MINOR.224   
      NXJP2K=NJP2+NXNM                                                     MINOR.225   
      NXJP1K=NJP1+NXNM                                                     MINOR.226   
      NXJNMK=NJ+NXNM                                                       MINOR.227   
      NXJM1K=NJM1+NXNM                                                     MINOR.228   
      NXJM2K=NJM2+NXNM                                                     MINOR.229   
      DO K=1,KMAXP1                                                        MINOR.230
        IF(J.GT.2.AND.J.LT.JMAXM1)THEN                                     MINOR.231
          DO I=1,LEN1                                                      MINOR.232   
            S9(I,K)=S10(I,K)                                               MINOR.233   
            S8(I,K)=F(I,NXJNMK)-C(26)*(F(I,NXJP2K)+F(I,NXJM2K)-4.*         MINOR.234
     1              (F(I,NXJP1K)+F(I,NXJM1K))+6.*F(I,NXJNMK))              MINOR.235   
          ENDDO                                                            MINOR.236
        ELSE                                                               MINOR.237
          DO I=1,LEN1                                                      MINOR.238   
            S9(I,K)=S10(I,K)                                               MINOR.239   
            S8(I,K)=F(I,NXJNMK)-C(26)*(-4.*(F(I,NXJP1K)+F(I,NXJM1K))+      MINOR.240  
     1              8.*F(I,NXJNMK))                                        MINOR.241   
          ENDDO                                                            MINOR.242
        ENDIF                                                              MINOR.243
        NXJP2K=NXJP2K+1                                                    MINOR.244
        NXJP1K=NXJP1K+1                                                    MINOR.245
        NXJNMK=NXJNMK+1                                                    MINOR.246
        NXJM1K=NXJM1K+1                                                    MINOR.247
        NXJM2K=NXJM2K+1                                                    MINOR.248
      ENDDO                                                                MINOR.249
      DO K=1,KMAXP1                                                        MINOR.250
        DO I=3,LEN1-2                                                      MINOR.251   
          S10(I,K)=S8(I,K)-C(26)*(S8(I+2,K)+S8(I-2,K)-4.*(S8(I+1,K)+       MINOR.252
     1             S8(I-1,K))+6.*S8(I,K))                                  MINOR.253   
        ENDDO                                                              MINOR.254
          S10(2,K)=S8(2,K)-C(26)*(-4.*(S8(3,K)+S8(1,K))+8.*S8(2,K))        MINOR.255
          S10(LEN1-1,K)=S8(LEN1-1,K)-C(26)*(-4.*(S8(LEN1,K)+               MINOR.256
     1                  S8(LEN1-2,K))+8.*S8(LEN1-1,K))                     MINOR.257
      ENDDO                                                                MINOR.258
C     ****                                                                 MINOR.259
C     ****     S1 = P, S2 = Q, S3 = R, S4= F                               MINOR.260
C     ****                                                                 MINOR.261   
      NWK=NJNP+NW-1                                                        MINOR.262   
      DO K=1,KMAX                                                          MINOR.263   
        NWK=NWK+1                                                          MINOR.264   
        DO I=1,LEN1                                                        MINOR.265   
          S1(I,K)=S11(I,K)/C(3)*(1./C(3)+.5*S12(I,K))-EXPS(K)*(C(87)*      MINOR.266   
     1            DIFK(K)*T7(I)*(1./C(3)-.5*S9(I,K))+0.25*(F(I,NWK)+       MINOR.267
     2            F(I,NWK+1)))/C(3)                                        MINOR.268
          S3(I,K)=S11(I,K+1)/C(3)*(1./C(3)-.5*S12(I,K+1))-EXPS(K)*         MINOR.269   
     1            (C(86)*DIFK(K+1)*T7(I)*(1./C(3)+.5*S9(I,K+1))-           MINOR.270   
     2            0.25*(F(I,NWK)+F(I,NWK+1)))/C(3)                         MINOR.271   
          S2(I,K)=-(S11(I,K)/C(3)*(1./C(3)-.5*S12(I,K))+S11(I,K+1)/        MINOR.272   
     1            C(3)*(1./ C(3)+.5*S12(I,K+1)))+EXPS(K)*((C(87)*          MINOR.273   
     2            DIFK(K)*(1./C(3)+.5*S9(I,K))+ C(86)*DIFK(K+1)*           MINOR.274   
     3            (1./C(3)-.5*S9(I,K+1)))*T7(I)/C(3)-S14(I,K)+C(7))        MINOR.275
          S4(I,K)=EXPS(K)*(S10(I,K)*C(7)-S13(I,K)+S15(I,K))                MINOR.276   
        ENDDO                                                              MINOR.277
      ENDDO                                                                MINOR.278
C     ****                                                                 MINOR.279
C     ****     IF IBNDB = 1, SET FLUX BOUNDARY CONDITION AT BOTTOM         MINOR.280
C     ****                                                                 MINOR.281  
      IF(IBNDB.EQ.1)THEN                                                   MINOR.282   
        NWK=NJNP+NW                                                        MINOR.283   
        DO I=1,LEN1                                                        MINOR.284   
          T1(I)=1.                                                         MINOR.285   
          T2(I)=S9(I,1)-F(I,NWK)/DIFK(1)                                   MINOR.286   
          T3(I)=T3(I)*C(54)*RMX/(DIFK(1)*C(81)*EXPS(1)*C(87)*C(85))        MINOR.287   
        ENDDO                                                              MINOR.288   
      ENDIF                                                                MINOR.289
C     ****                                                                 MINOR.290
C     ****     BOUNDARIES                                                  MINOR.291   
C     ****     MODIFY EX(KMAXP1) IF IBND=1                                 MINOR.292
C     ****                                                                 MINOR.293   
      IF(IBND.EQ.1)THEN                                                    MINOR.294   
        NWK=NJNP+NW+KMAX                                                   MINOR.295   
        DO I=1,LEN1                                                        MINOR.296   
          T7(I)=EXPS(KMAX)*C(86)*F(I,NWK)/S11(I,KMAXP1)                    MINOR.297   
          S12(I,KMAXP1)=S12(I,KMAXP1)-T7(I)                                MINOR.298   
        ENDDO                                                              MINOR.299   
      ENDIF                                                                MINOR.300   
      DO I=1,LEN1                                                          MINOR.301   
C       ****                                                               MINOR.302
C       ****     LOWER BOUNDARY                                            MINOR.303
C       ****                                                               MINOR.304
        S2(I,1)=S2(I,1)+S1(I,1)*(T1(I)+.5*T2(I)*C(3))/(T1(I)-.5*           MINOR.305   
     1          T2(I)*C(3))                                                MINOR.306   
        S4(I,1)=S4(I,1)-S1(I,1)*T3(I)*C(3)/(T1(I)-.5*T2(I)*C(3))           MINOR.307   
        S1(I,1)=0.                                                         MINOR.308
C       ****                                                               MINOR.309 
C       ****     UPPER BOUNDARY                                            MINOR.310
C       ****                                                               MINOR.311   
        IF(IBND.EQ.0.OR.IBND.EQ.1)THEN                                     MINOR.312
C         ****                                                             MINOR.313   
C         ****     UPWARD NUMBER FLUX IS IN T4                             MINOR.314
C         ****                                                             MINOR.315   
          S1(I,KMAXP1)=1.+.5*C(3)*S12(I,KMAXP1)                            MINOR.316   
          S2(I,KMAXP1)=S1(I,KMAXP1)-2.                                     MINOR.317   
          S3(I,KMAXP1)=0.                                                  MINOR.318   
          S4(I,KMAXP1)=-C(54)*RMX*T4(I)*C(3)/(C(81)*S11(I,KMAXP1)*C(85))   MINOR.319   
        ELSE                                                               MINOR.320
C         ****                                                             MINOR.321   
C         ****     VALUE AT UPPER BNDRY IN T4                              MINOR.322
C         ****                                                             MINOR.323   
          S1(I,KMAXP1)=.5                                                  MINOR.324   
          S2(I,KMAXP1)=.5                                                  MINOR.325   
          S3(I,KMAXP1)=0.                                                  MINOR.326   
          S4(I,KMAXP1)=T4(I)                                               MINOR.327   
        ENDIF                                                              MINOR.328   
      ENDDO                                                                MINOR.329
C     ****                                                                 MINOR.330   
C     ****     SOLVE TRIDIAGONAL SYSTEM                                    MINOR.331
C     ****                                                                 MINOR.332 
      NXNPK=NJNP+NX                                                        MINOR.333 
      CALL TRSOLV(S1,S2,S3,S4,S7,F(1,NXNPK),LEN1,2,LEN1-1,KMAXP1,1,        MINOR.334   
     1KMAXP1,1)                                                            MINOR.335
C     ****                                                                 MINOR.  
C     ****     BOUNDARY VALUES FROM GENERAL CIRCULATION MODEL              MINOR. 
C     ****                                                                 MINOR.
      CALL N2NESTBOUN(J,NX,LEVEL,NTIME)                                    MINOR.
C     ****                                                                 MINOR.336
C     ****     FIXED BOUNDARY CONDITIONS                                   MINOR.337
C     ****                                                                 MINOR.338
C      CALL FIX1(NX)                                                       MINOR.339
C     ****                                                                 MINOR.340
C     ****      RADIATION BOUNDARY CONDITIONS                              MINOR.345
C     ****                                                                 MINOR.346
C       CALL SBOUNDSF(NX,IN)                                               MINOR.347
C       CALL SBOUNDSL(NX,IN)                                               MINOR.348
C     ****                                                                 MINOR.349   
C     ****     FILTER NX                                                   MINOR.350
C     ****                                                                 MINOR.351  
C      IF(KUTT(J).LT.IMAXH)THEN                                            MINOR.352   
C          NXNPK=NJNP+NX                                                   MINOR.353   
C          CALL FILTER2(NXNPK,KMAXP1,KUTT(J))                              MINOR.354   
C      ENDIF                                                               MINOR.355  
C     ****                                                                 MINOR.336 
C     ****     TIME SMOOTHING                                              MINOR.337
C     ****                                                                 MINOR.338   
      CALL N2SMOOTH(NX,NXNM)                                               MINOR.339
C     ****                                                                 MINOR.340
C     ****     INSURE NON-NEGATIVE NX                                      MINOR.341
C     ****                                                                 MINOR.342   
      NXK=NJNP+NX                                                          MINOR.343   
      NXNMK=NJNP+NXNM                                                      MINOR.344   
      DO K=1,KMAXP1                                                        MINOR.345
        DO I=1,LEN1                                                        MINOR.346   
          CVMGP=F(I,NXK)-SMALL                                             MINOR.347
          IF(CVMGP.LE.0.)THEN                                              MINOR.348
            F(I,NXK)=SMALL                                                 MINOR.349
          ENDIF                                                            MINOR.350
          CVMGP=F(I,NXNMK)-SMALL                                           MINOR.351
          IF(CVMGP.LE.0.)THEN                                              MINOR.352
            F(I,NXNMK)=SMALL                                               MINOR.353   
          ENDIF                                                            MINOR.354
        ENDDO                                                              MINOR.355
        NXK=NXK+1                                                          MINOR.356
        NXNMK=NXNMK+1                                                      MINOR.357
      ENDDO                                                                MINOR.358
      RETURN                                                               MINOR.359
      END                                                                  MINOR.360   
C                                                                          MINOR.361
*DK   N2NESTIN                                                            NESTIN.1
      SUBROUTINE N2NESTIN(W,NHIST,NLEVEL)                                 NESTIN.2
      INCLUDE 'n1param.h'                                                 NESTIN.3
      INCLUDE 'n1array.h'                                                 NESTIN.4
      INCLUDE 'nestcnt.h'                                                 NESTIN.5
      INCLUDE 'n2nestg.h'                                                 NESTIN.6
      DIMENSION W(NNX,KMXP*(NHIST+7)+1,NJX)                               NESTIN.7
C     ****                                                                NESTIN.8
C     ****     SPECIFY INITIAL VALUES OF THE NESTED GRID DOMAIN BY        NESTIN.9
C     ****     LINEAR INTERPOLATION OF THE COARSE GRID VALUES             NESTIN.10
C     ****                                                                NESTIN.11
      RATIO=DBLE(NESTRI(NLEVEL))                                          NESTIN.12
      DO K=1,ZKMXP*NHIST+1                                                NESTIN.13
       DO J=1,JNX                                                         NESTIN.14
C       ****                                                              NESTIN.15
C       ****     FIRST LINE IN LATITUDE                                   NESTIN.16
C       ****                                                              NESTIN.17
        IF(J.EQ.1)THEN                                                    NESTIN.18
         DO I=1,INX                                                       NESTIN.19
          II=NESTRI(NLEVEL)*(I-1)+1                                       NESTIN.20
          IC=NESTI1(NLEVEL)+I-1                                           NESTIN.21
          JJ=NESTJ1(NLEVEL)+J-1                                           NESTIN.22
          IF(I.LT.INX)THEN                                                NESTIN.23
           W(II,K,J)=G(IC,K,JJ)                                           NESTIN.24
           DO L=1,NESTRI(NLEVEL)-1                                        NESTIN.25
            IL=II+L                                                       NESTIN.26
            W(IL,K,J)=G(IC,K,JJ)+DBLE(L)*(G(IC+1,K,JJ)-G(IC,K,JJ))/RATIO  NESTIN.27
           ENDDO                                                          NESTIN.28
          ELSE                                                            NESTIN.29
           W(II,K,J)=G(IC,K,JJ)                                           NESTIN.30
          ENDIF                                                           NESTIN.31
         ENDDO                                                            NESTIN.32
        ELSE                                                              NESTIN.33
C        ****                                                             NESTIN.34
C        ****     NEXT LINE IN LATITUDE                                   NESTIN.35
C        ****                                                             NESTIN.36
         J2=NESTRI(NLEVEL)*(J-1)+1                                        NESTIN.37
         J1=NESTRI(NLEVEL)*(J-2)+1                                        NESTIN.38
         JJ=NESTJ1(NLEVEL)+J-1                                            NESTIN.39
         DO I=1,INX                                                       NESTIN.40
          II=NESTRI(NLEVEL)*(I-1)+1                                       NESTIN.41
          IC=NESTI1(NLEVEL)+I-1                                           NESTIN.41
          IF(I.LT.INX)THEN                                                NESTIN.42
           W(II,K,J2)=G(IC,K,JJ)                                          NESTIN.43
           DO L=1,NESTRI(NLEVEL)-1                                        NESTIN.44
            IL=II+L                                                       NESTIN.45
            W(IL,K,J2)=G(IC,K,JJ)+                                        NESTIN.46
     1                 DBLE(L)*(G(IC+1,K,JJ)-G(IC,K,JJ))/RATIO            NESTIN.47
           ENDDO                                                          NESTIN.48
          ELSE                                                            NESTIN.49
           W(II,K,J2)=G(IC,K,JJ)                                          NESTIN.50
          ENDIF                                                           NESTIN.51
         ENDDO                                                            NESTIN.52
C        ****                                                             NESTIN.53
C        ****     CALCULATE LATITUDINAL LINES IN BETWEEN                  NESTIN.54
C        ****                                                             NESTIN.55
         DO I=1,NNX                                                       NESTIN.56
          DO L=1,NESTRI(NLEVEL)-1                                         NESTIN.57
           W(I,K,J2-L)=W(I,K,J2)-DBLE(L)*(W(I,K,J2)-W(I,K,J1))/RATIO      NESTIN.58
          ENDDO                                                           NESTIN.59
         ENDDO                                                            NESTIN.60
        ENDIF                                                             NESTIN.61
       ENDDO                                                              NESTIN.62
      ENDDO                                                               NESTIN.63
      RETURN                                                              NESTIN.64
      END                                                                 NESTIN.65
C                                                                         NESTIN.66
*DK NEW                                                                      NEW.1
      SUBROUTINE N2NEW(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 'n2param.h'                                                    NEW.9
      INCLUDE 'n2const.h'                                                    NEW.10
      include 'n2phycs.h'
      DIMENSION TR(IMX,KMXP),RNU(IMX,KMXP,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 N2NEWTO3P                                               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 'n2param.h'                                                NEWTO3P.10
      INCLUDE 'n2array.h'                                                NEWTON.8
      INCLUDE 'n2cvscr.h'                                                NEWTO3P.11
      INCLUDE 'n2const.h'                                                NEWTO3P.12
      INCLUDE 'index.h'                                                  NEWTO3P.13
      INCLUDE 'buffe.h'                                                  NEWTO3P.14
      DIMENSION AN(3),BN(3),XFAC(KMXP)                                   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 N2NEWTON                                                 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 'n2param.h'                                                 NEWTON.8
      INCLUDE 'n2array.h'                                                 NEWTON.8
      INCLUDE 'n2cvscr.h'                                                 NEWTON.9
      INCLUDE 'n2const.h'                                                 NEWTON.10
      INCLUDE 'index.h'                                                   NEWTON.11
      INCLUDE 'buffe.h'                                                   NEWTON.12
      REAL*8 NOB                                                          NEWTON.13
      COMMON/N2RUNT/TTBOUND,NOB(JMX),AVTO,HOR(JMX)                        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 N2OPFLUX(LEVEL)                                          OPFLUX.2
C     ****                                                                OPFLUX.3
C     ****     CALCULATES UPWARD O+ NUMBER FLUX IN T7                     OPFLUX.4
C     ****                                                                OPFLUX.5
      INCLUDE 'n2param.h'                                                 OPFLUX.6
      INCLUDE 'n2cvscr.h'                                                 OPFLUX.7
      INCLUDE 'n2const.h'                                                 OPFLUX.8
      INCLUDE 'n2phycs.h'                                                 OPFLUX.9
      INCLUDE 'start.h'                                                   OPFLUX.10
      INCLUDE 'nestcnt.h'
      COMMON/N2TRGM/RLATM(IMX,JMX),RLONM(IMX,JMX),                        OPFLUX.11
     1      DIPMAG(IMX,JMX),DECMAG(IMX,JMX),SNDEC(IMX,JMX),               OPFLUX.12
     2      CSDC(IMX,JMX),SN2DEC(IMX,JMX),SNCSDC(IMX,JMX),                OPFLUX.13
     3      RLATMP(JMX),RLONMP(JMX),DLONS(JMX)                            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=PHIS(LEVEL)*C(110)/180.+DBLE(J-1)*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.+(2.D0*C(110)+SLAM(LEVEL)*C(110)/180.+
     1       C(1)*DBLE(I-1))*12.D0/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 N2OPLUS(LEVEL,NTIME)                                      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 'n2param.h'                                                  OPLUS.8
      INCLUDE 'n2cvscr.h'                                                  OPLUS.9
      INCLUDE 'n2array.h'                                                  OPLUS.9
      INCLUDE 'n2const.h'                                                  OPLUS.10
      INCLUDE 'index.h'                                                    OPLUS.11
      INCLUDE 'buffe.h'                                                    OPLUS.12
      INCLUDE 'n2phycs.h'                                                  OPLUS.13
      INCLUDE 'n2rates.h'                                                  OPLUS.14
C     ****                                                                 OPLUS.15
C     ****     COMMON BLOCK DESCRIBING MAGNETIC FIELD                      OPLUS.16
C     ****                                                                 OPLUS.17
      COMMON/N2MAGFLD/BX(IMX,JMX),BY(IMX,JMX),BZ(IMX,JMX),BMOD(IMX,JMX)
      DIMENSION KUTT(JMX),XNEU(IMX,KMXP)                                   OPLUS.21
      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 N2DIVB(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 N2RRK(F(1,NTJM1K),F(1,NMSM1K),F(1,NPS1MK),F(1,NPS2MK),S4,S13)   OPLUS.63
      CALL N2RRK(F(1,NTK),F(1,NMSK),F(1,NPS1K),F(1,NPS2K),S5,S14)          OPLUS.64
      CALL N2RRK(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 N2DIFFUS(S4,F(1,NOPM1K),S10,S7)                                 OPLUS.90
      CALL N2DIFFUS(S5,F(1,NOPK),S11,S8)                                   OPLUS.91
      CALL N2DIFFUS(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 N2BDOTDH(S7,S8,S9,J,S9,0)                                       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
      IF(J.EQ.2)THEN                                                       OPLUS.162
       CALL N2BDOTDH(S3,S4,S5,J-1,S1,-1)                                   OPLUS.163  
       CALL N2BDOTDH(S4,S5,S6,J,S2,0)                                      OPLUS.164  
       CALL N2BDOTDH(S5,S6,S7,J+1,S3,0)                                    OPLUS.165  
      ELSEIF(J.EQ.JMAXM1)THEN                                              OPLUS.166
       CALL N2BDOTDH(S3,S4,S5,J-1,S1,0)                                    OPLUS.167  
       CALL N2BDOTDH(S4,S5,S6,J,S2,0)                                      OPLUS.168  
       CALL N2BDOTDH(S5,S6,S7,J+1,S3,1)                                    OPLUS.169  
      ELSE                                                                 OPLUS.170
       CALL N2BDOTDH(S3,S4,S5,J-1,S1,0)                                    OPLUS.171  
       CALL N2BDOTDH(S4,S5,S6,J,S2,0)                                      OPLUS.172  
       CALL N2BDOTDH(S5,S6,S7,J+1,S3,0)                                    OPLUS.173  
      ENDIF                                                                OPLUS.174
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 N2BDOTDH(S1,S2,S3,J,S8,0)                                           OPLUS.144
C     ****                                                                 OPLUS.145
C     ****      S7 = (BZ*D/(H*DZ)+DIV(*B))*S2                              OPLUS.146
C     ****                                                                 OPLUS.147
      CALL N2BDZDVB(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=2,Len1-1                                                       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
      CALL N2FILTER2(S4,J,KMAX,LEVEL)
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
      DO K=1,KMAX                                                          OPLUS.293
       DO I=2,LEN1-1                                                         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
      CALL N2FILTER2(S7,J,KMAX,LEVEL)
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 K=1,KMAX
       IF(J.GT.2.AND.J.LT.JMAXM1)THEN                                      OPLUS.376       
        DO I=1,LEN1                                                        OPLUS.329
         S1(I,K)=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
       ELSE 
        DO I=1,LEN1                                                        OPLUS.382
         S1(I,K)=F(I,NOJNMK)-C26*(-4.*(F(I,NOJP1K)+F(I,NOJM1K))+           OPLUS.383
     1           8.*F(I,NOJNMK))                                           OPLUS.384 
          ENDDO                                                            OPLUS.385  
       ENDIF                                                               OPLUS.386
       NOJP2K=NOJP2K+1                                                     OPLUS.387
       NOJP1K=NOJP1K+1                                                     OPLUS.388
       NOJNMK=NOJNMK+1                                                     OPLUS.389
       NOJM1K=NOJM1K+1                                                     OPLUS.390
       NOJM2K=NOJM2K+1                                                     OPLUS.391
      ENDDO                                                                OPLUS.392       
      DO K=1,KMAX                                                          OPLUS.393
        DO I=3,LEN1-2                                                      OPLUS.394
          S4(I,K)=S4(I,K)-(S1(I,K)-C(26)*(S1(I+2,K)+S1(I-2,K)-4.*(         OPLUS.395 
     1            S1(I+1,K)+S1(I-1,K))+6.*S1(I,K)))*C(7)                   OPLUS.396 
        ENDDO                                                              OPLUS.397
         S4(2,K)=S4(2,K)-(S1(2,K)-C(26)*(-4.*(S1(3,K)                      OPLUS.398
     1            +S1(1,K))+8.*S1(2,K)))*C(7)                              OPLUS.399
         S4(LEN1-1,K)=S4(LEN1-1,K)-(S1(LEN1-1,K)-C(26)*(-4.*(S1(LEN1,K)    OPLUS.400
     1                +S1(LEN1-2,K))+8.*S1(LEN1-1,K)))*C(7)                OPLUS.401
      ENDDO                                                                OPLUS.402
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.16)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
c       if(j.eq.34)write(6,*)S4(I,1),F(I,NQOPK),S13(I,1),S13(I,2),i
       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.16)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,2,LEN1-1,KMAXP1,1,KMAX,    OPLUS.496
     11)                                                                   OPLUS.497
C     ****                                                                  
C     ****     BOUNDARY VALUES FROM GENERAL CIRCULATION MODEL               
C     ****                                                                     
      CALL N2NESTBOUN(J,NOP,LEVEL,NTIME)
C     ****                                                                 OPLUS.505
C     ****     TIME SMOOTHING                                              OPLUS.506
C     ****                                                                 OPLUS.507
      CALL N2SHAPIRO2(NOP,KMAX)
      CALL N2SMOOTH(NOP,NOPNM)    
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 N2ORORA                                                   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 'n2param.h'                                                  ORORA.11
      INCLUDE 'n2cvscr.h'                                                  ORORA.12
      INCLUDE 'n2const.h'                                                  ORORA.13
      INCLUDE 'n2array.h'
      INCLUDE 'index.h'                                                    ORORA.14
      INCLUDE 'buffe.h'                                                    ORORA.15
      INCLUDE 'n2phycs.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
      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
      K0=0
      DO I=LEN1+1,LEN2                                                     ORORA.115
       F(I,NQO2PK)=F(I,NQO2PK)+DSQRT(S13(I,1)*S13(I,K0))                   ORORA.116
       F(I,NQOPK)=F(I,NQOPK)+DSQRT(S14(I,1)*S14(I,K0))                     ORORA.117
       F(I,NQN2PK)=F(I,NQN2PK)+DSQRT(S15(I,1)*S15(I,K0))                   ORORA.118
       F(I,NQNPK)=F(I,NQNPK)+2.2D-1/7.D-1*DSQRT(S15(I,1)*S15(I,K0))        ORORA.119
      ENDDO                                                                ORORA.120
C     ****                                                                 ORORA.121
C     ****      LEVELS 1 AND KMAXP1                                        ORORA.122
C     ****                                                                 ORORA.123
      DO I=1,LEN1                                                          ORORA.124
      F(I,NQO2PK)=F(I,NQO2PK)+1.5*S13(I,1)-0.5*S13(I,2)                    ORORA.125
      F(I,NQOPK)=F(I,NQOPK)+1.5*S14(I,1)-0.5*S14(I,2)                      ORORA.126
      F(I,NQN2PK)=F(I,NQN2PK)+1.5*S15(I,1)-0.5*S15(I,2)                    ORORA.127
      F(I,NQNPK)=F(I,NQNPK)+2.2D-1/7.D-1*(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)+2.2D-1/7.D-1*(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 N2POLHT(QP,IM)                                            POLHT.2     
C     ****                                                                 POLHT.3
C     ****     CALCULATES HORIZONTAL VARIATION OF POLAR CUSP HEATING       POLHT.4     
C     ****                                                                 POLHT.6
      INCLUDE 'n2param.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)                                       POLHT.9     
      COMMON/N2ANGLE/ALON(IMX),COLAT(IMX)                                  POLHT.10
      DIMENSION QP(1)                                                      POLHT.11    
      DATA S5/.08726646/,S20/.34906585/,S2/.03490659/,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))/S2)**2)+                               POLHT.19
     1       DEXP(-((PI-RAD-COLAT(I))/S2)**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 N2QINITE                                                 QINITE.2
C     ****                                                                QINITE.3
C     ****      CALCULATE BACKGROUND IONIZATION RATES                     QINITE.4
C     ****                                                                QINITE.5
      INCLUDE 'n2param.h'                                                 QINITE.6
      INCLUDE 'n2array.h'                                                 QINITE.6
      INCLUDE 'n2cvscr.h'                                                 QINITE.7
      INCLUDE 'n2const.h'                                                 QINITE.8
      INCLUDE 'index.h'                                                   QINITE.9
      INCLUDE 'buffe.h'                                                   QINITE.10
      INCLUDE 'n2rates.h'                                                 QINITE.11
      INCLUDE 'n2cpbnd.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)+6.7D-1*S6(I,1)*S5(I,1)                     QINITE.123
       F(I,NQOPK)=F(I,NQOPK)+(3.3D-1*S6(I,1)+S7(I,1))*S5(I,1)             QINITE.124
       F(I,NQN2PK)=F(I,NQN2PK)+8.6D-1*S8(I,1)*S5(I,1)                     QINITE.125
       F(I,NQNPK)=F(I,NQNPK)+1.4D-1*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 N2QJION                                                   QJION.2
C     ****                                                                 QJION.3
C     ****     CALCULATES ION CHEMISTRY CONTRIBUTION TO NEUTRAL GAS        QJION.4
C     ****     HEATING                                                     QJION.5
C     ****                                                                 QJION.6
      INCLUDE 'n2param.h'                                                  QJION.7
      INCLUDE 'n2array.h'                                                  QJION.7
      INCLUDE 'n2cvscr.h'                                                  QJION.8
      INCLUDE 'n2const.h'                                                  QJION.9
      INCLUDE 'index.h'                                                    QJION.10
      INCLUDE 'buffe.h'                                                    QJION.11
      INCLUDE 'n2phycs.h'                                                  QJION.12
      INCLUDE 'n2rates.h'                                                  QJION.13
      COMMON/MASS/RMN4S,RMN2D,RMNO,BRN2D,CEE                               QJION.14
      DIMENSION AUREFF(KMXP)                                               QJION.15
      DATA AUREFF/KMXP*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 N2QJNNO                                                   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 'n2param.h'                                                  QJNNO.10
      INCLUDE 'n2array.h'                                                  QJNNO.10
      INCLUDE 'n2cvscr.h'                                                  QJNNO.11
      INCLUDE 'n2const.h'                                                  QJNNO.12
      INCLUDE 'index.h'                                                    QJNNO.13
      INCLUDE 'buffe.h'                                                    QJNNO.14
      INCLUDE 'n2rates.h'                                                  QJNNO.15
      include 'n2phycs.h'
      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
      K0=0
      DO I=LEN1+1,LEN2                                                     QJNNO.61
       S7(I,1)=S2(I,K0)*S2(I,1)                                            QJNNO.62
       IF(S7(I,1).LE.0.)S7(I,1)=1.D-20                                     QJNNO.63
      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 QRJ                                                                      QRJ.1
      SUBROUTINE N2QRJ                                                       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 'n2param.h'                                                    QRJ.8
      INCLUDE 'n2array.h'                                                    QRJ.8
      INCLUDE 'n2cvscr.h'                                                    QRJ.9
      INCLUDE 'n2const.h'                                                    QRJ.10
      INCLUDE 'index.h'                                                      QRJ.11
      INCLUDE 'buffe.h'                                                      QRJ.12
      INCLUDE 'n2phycs.h'                                                    QRJ.13
      INCLUDE 'n2rates.h'                                                    QRJ.14
      INCLUDE 'n2cpbnd.h'                                                    QRJ.14
      COMMON/DATES/FEUV(59),FSRC(15),SIGEUV(3,59),SIGMAS(6,59),              QRJ.15
     &            SIGSRC(15),RLMSRC(15),EUVEFF(KMXP),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 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.2) 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.174
C     ****     COMPUTE S14 = RSQ, S15 = RSP                                  QRJ.175
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)*2.2D-1)*S5(I,1)               QRJ.408
       QOP2D(I,1)=(QOP2D(I,1)+S4(I,1)*S14(I,1)*2.4D-1)*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
      ENDDO                                                                  QRJ.414
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 N2QTIEFF                                                 QTIEFF.2
C     ****                                                                QTIEFF.3
C     ****     CALCULATES ELECTRON PRODUCTION OF N4S AND N2D IN NQTEF     QTIEFF.4
C     ****                                                                QTIEFF.5
      INCLUDE 'n2param.h'                                                 QTIEFF.6
      INCLUDE 'n2array.h'                                                 QTIEFF.6
      INCLUDE 'n2const.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 N2RATES                                                   RATES.2
C     ****                                                                 RATES.3
C     ****     COMPUTES NEEDED REACTION RATES IN COMMON BLOCK/RATES/       RATES.4
C     ****                                                                 RATES.5
      INCLUDE 'n2param.h'                                                  RATES.6
      INCLUDE 'n2array.h'                                                  RATES.6
      INCLUDE 'n2cvscr.h'                                                  RATES.7
      INCLUDE 'n2const.h'                                                  RATES.8
      INCLUDE 'index.h'                                                    RATES.9
      INCLUDE 'buffe.h'                                                    RATES.10
      INCLUDE 'n2phycs.h'                                                  RATES.11
      INCLUDE 'n2rates.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 N2ROTATE                                                 ROTATE.2
C     ****                                                                ROTATE.3
C     ****     ROTATES LAMDAS                                             ROTATE.4
C     ****                                                                ROTATE.5
      INCLUDE 'n2param.h'                                                 ROTATE.6
      INCLUDE 'n2array.h'                                                 ROTATE.6
      INCLUDE 'n2cvscr.h'                                                 ROTATE.7
      INCLUDE 'n2const.h'                                                 ROTATE.8
      INCLUDE 'index.h'                                                   ROTATE.9
      INCLUDE 'n2phycs.h'                                                 ROTATE.10
      COMMON/N2TRGM/RLATM(IMX,JMX),RLONM(IMX,JMX),                        ROTATE.11
     1      DIPMAG(IMX,JMX),DECMAG(IMX,JMX),SNDEC(IMX,JMX),               ROTATE.12
     2      CSDEC(IMX,JMX),SN2DEC(IMX,JMX),SNCSDC(IMX,JMX),               ROTATE.13
     3      RLATMP(JMX),RLONMP(JMX),DLONS(JMX)                            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,IMAX                                                        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
      RETURN                                                              ROTATE.48
      END                                                                 ROTATE.49
C                                                                         ROTATE.50
*DK RRK                                                                      RRK.1     
      SUBROUTINE N2RRK(T,RMS,PS1,PS2,TP,ANS)                                 RRK.2     
C     ****                                                                   RRK.3     
C     ****      EVALUATES  ANS = K (DIFFUSION COEFFICIENT)                   RRK.4     
C     ****                                                                   RRK.5     
      include 'n2param.h'                                                    RRK.6     
      include 'n2const.h'                                                    RRK.7     
      COMMON/MASS/RMN4S,RMN2D,RMNO,BRN2D,CEE                                 RRK.8     
      DIMENSION T(IMX,KMXP),RMS(IMX,KMXP),PS1(IMX,KMXP),                     RRK.9     
     A PS2(IMX,KMXP),TP(IMX,KMXP),ANS(IMX,KMXP)                              RRK.10    
C     ****                                                                   RRK.11    
C     ****      SET UP EXPS ARRAY                                            RRK.12    
C     ****                                                                   RRK.13    
      CEE=1.50                    !no way to find this parameter in TIGCM    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 K=1,KMAX                                                            RRK.20    
        DO I=1,LEN1                                                          RRK.21
          ANS(I,K)=1.42D17*C(84)*T(I,K)/(C(81)*ANS(I,K)*.5*(RMS(I,K)+        RRK.22    
     A     RMS(I,K+1))*(PS2(I,K)/RMASS(2)*DSQRT(TP(I,K))*(1.-0.064*          RRK.23    
     B     DLOG10(TP(I,K)))**2*CEE+18.6*(1.-PS1(I,K)-PS2(I,K))/RMASS(3)      RRK.24    
     C     +18.1*PS1(I,K)/RMASS(1)))                                         RRK.25    
        ENDDO                                                                RRK.26    
      ENDDO                                                                  RRK.27
      RETURN                                                                 RRK.28    
      END                                                                    RRK.29    
C                                                                            RRK.30
*DK SETTEI                                                                SETTEI.1
      SUBROUTINE N2SETTEI(LEVEL)                                          SETTEI.2
C     ****                                                                SETTEI.3
C     ****     CALCULATE ELECTRON AND ION TEMPERATURES                    SETTEI.4
C     ****                                                                SETTEI.5
      INCLUDE 'n2param.h'                                                 SETTEI.6
      INCLUDE 'n2array.h'                                                 SETTEI.6
      INCLUDE 'n2cvscr.h'                                                 SETTEI.7
      INCLUDE 'n2const.h'                                                 SETTEI.8
      INCLUDE 'index.h'                                                   SETTEI.9
      INCLUDE 'start.h'                                                   SETTEI.10
      INCLUDE 'buffe.h'                                                   SETTEI.11
      INCLUDE 'n2phycs.h'                                                 SETTEI.12
      INCLUDE 'n2rates.h'                                                 SETTEI.13
      INCLUDE 'nestcnt.h'
      COMMON/N2TRGM/RLATM(IMX,JMX),RLONM(IMX,JMX),                           SETTEI.14
     1      DIPMAG(IMX,JMX),DECMAG(IMX,JMX),SNDEC(IMX,JMX),                SETTEI.15
     2      CSDC(IMX,JMX),SN2DEC(IMX,JMX),SNCSDC(IMX,JMX),                SETTEI.16
     3      RLATMP(JMX),RLONMP(JMX),DLONS(JMX)                            SETTEI.17
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=PHIS(LEVEL)*C(110)/180.+DBLE(J-1)*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.+(2.*C(110)+SLAM(LEVEL)*C(110)/180.+
     1       DBLE(I-1)*C(1))*12.D0/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
c       write(6,*)S10(I,1),S11(I,1),S13(I,1),S12(I,1),S15(I,1),i
       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
c       if(j.eq.2)write(6,*)S15(I,1),S5(I,1),F(I,NOPK),F(I,NO2PK),
c     1            F(I,NNOPK),i
       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,1,LEN1,KMAXP1,1,KMAX      SETTEI.450
     1,1)                                                                 SETTEI.451
      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.3000.)F(I,NTEK+K)=3000.
       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 SWDOT                                                                  SWDOT.1
      SUBROUTINE N2SWDOT(NTIME,LEVEL)                                      SWDOT.2
C     ****                                                                 SWDOT.3
C     ****     CALCULATES W ON LINE NJ AND Z TO NJNP                       SWDOT.4
C     ****                                                                 SWDOT.5
      INCLUDE 'n2param.h'                                                  SWDOT.6
      INCLUDE 'n2array.h'                                                  SWDOT.7
      INCLUDE 'n2cvscr.h'                                                  SWDOT.8
      INCLUDE 'buffe.h'                                                    SWDOT.9
      INCLUDE 'n2const.h'                                                  SWDOT.10
      INCLUDE 'index.h'                                                    SWDOT.11
      INCLUDE 'n2phycs.h'                                                  SWDOT.12
C     ****                                                                 SWDOT.13
C     ****     S1=DIVRG(V)                                                 SWDOT.14
c     ****                                                                 SWDOT.15
      IF(J.GE.2.AND.J.LE.JMAX-1)THEN                                       SWDOT.16
        CALL N2DIVRG(S1)                                                   SWDOT.17
      ELSE                                                                 SWDOT.18
        CALL N2DIVRG1(S1)                                                  SWDOT.19
      ENDIF                                                                SWDOT.20
C     ****                                                                 SWDOT.21
C     ****     W(KMAXP1)=S1(KMAX)                                          SWDOT.22
C     ****     the upper boundary condition is w = div V                   SWDOT.23
C     ****                                                                 SWDOT.24
      NWK=NJNP+NW                                                          SWDOT.25
      DO I=1,LEN1                                                          SWDOT.26
        F(I,NWK+KMAX)=S1(I,KMAX)                                           SWDOT.27
      ENDDO                                                                SWDOT.28
C     ****                                                                 SWDOT.29
C     ****     W(K)=C(86)*(C(86)*W(K+1)+C(3)*S1(K))                        SWDOT.30
C     ****                                                                 SWDOT.31
      NWK=NWK+KMAX                                                         SWDOT.32
      DO KK=1,KMAX                                                         SWDOT.33
        K=KMAXP1-KK                                                        SWDOT.34
        NWK=NWK-1                                                          SWDOT.35
        DO I=1,LEN1                                                        SWDOT.36
          F(I,NWK)=C(86)*(C(86)*F(I,NWK+1)+C(3)*S1(I,K))                   SWDOT.37
        ENDDO                                                              SWDOT.38
      ENDDO                                                                SWDOT.39
      NZNPK=NJNP+NZ                                                        SWDOT.40
      NZK=NJ+NZ                                                            SWDOT.41
      DO K=1,KMAXP1                                                        SWDOT.42
        DO I=1,LEN1                                                        SWDOT.43
          F(I,NZNPK)=F(I,NZK)                                              SWDOT.44
        ENDDO                                                              SWDOT.45
        NZNPK=NZNPK+1                                                      SWDOT.46
        NZK=NZK+1                                                          SWDOT.47
      ENDDO                                                                SWDOT.48
      NWK=NJNP+NW                                                        
      CALL N2NESTBOUN(J,NW,LEVEL,NTIME)
      CALL N2FILTER(NW,J,KMAXP1,LEVEL)
      CALL N2SHAPIRO2(NW,KMAXP1)
      RETURN                                                               SWDOT.51
      END                                                                  SWDOT.52
C                                                                          SWDOT.53
*DK N2TIDE                                                                  TIDE.1
      SUBROUTINE N2TIDE                                                     TIDE.2
      INCLUDE 'n2param.h'                                                   TIDE.3
      INCLUDE 'n2const.h'                                                   TIDE.4
      INCLUDE 'nestcnt.h'                                                   TIDE.5
      INCLUDE 'start.h'                                                     TIDE.6
C     ****                                                                  TIDE.7
C     ****     PERFORM LINEAR INTERPOLATION OF THE TIDE PERTURBATION FOR    TIDE.8
C     ****     THE NESTED GRID                                              TIDE.9
C     ****                                                                  TIDE.10
      LEVEL=2                                                               TIDE.11
      CALL N2TIDEIN(ZB,TB,UB,VB,BND,LEVEL,0)                                TIDE.12
      CALL N2TIDEIN(ZB2,TB2,UB2,VB2,BND2,LEVEL,1)                           TIDE.13
      CALL N2TIDEIN(ZBA,TBA,UBA,VBA,BNDA,LEVEL,2)                           TIDE.14
      RETURN                                                                TIDE.15
      END                                                                   TIDE.16
C                                                                           TIDE.17
*DK TIDEIN                                                                TIDEIN.1
      SUBROUTINE N2TIDEIN(ZP,TP,UP,VP,BP,LEVEL,INDEX)                     TIDEIN.2
C     ****                                                                TIDEIN.3
C     ****     INTERPOLATE TIDE PERTURBATIONS FOR THE USE IN THE NESTED   TIDEIN.4
C     ****     GRID                                                       TIDEIN.5
C     ****                                                                TIDEIN.6
      INCLUDE "n1param.h"                                                 TIDEIN.7
      INCLUDE "n1const.h"                                                 TIDEIN.8
      INCLUDE "n2nestg.h"                                                 TIDEIN.9
      INCLUDE 'nestcnt.h'                                                 TIDEIN.10
      DIMENSION ZP(NJX),TP(NJX),UP(NJX),VP(NJX),BP(NNX)                   TIDEIN.11
      COMPLEX*16 ZP,TP,UP,VP,BP                                           TIDEIN.12
      DIMENSION ZT(NJX),TT(NJX),UT(NJX),VT(NJX),BT(NNX)                   TIDEIN.13
      COMPLEX*16 ZT,TT,UT,VT,BT                                           TIDEIN.14
      IF(INDEX.EQ.0)THEN                                                  TIDEIN.15
       DO J=1,JMAX                                                        TIDEIN.16
        ZT(J)=ZB(J)                                                       TIDEIN.17
        TT(J)=TB(J)                                                       TIDEIN.18
        UT(J)=UB(J)                                                       TIDEIN.19
        VT(J)=VB(J)                                                       TIDEIN.20
       ENDDO                                                              TIDEIN.21
       DO I=1,LEN1                                                        TIDEIN.22
        BT(I)=BND(I)                                                      TIDEIN.23
       ENDDO                                                              TIDEIN.24
      ELSE IF(INDEX.EQ.1)THEN                                             TIDEIN.25
       DO J=1,JMAX                                                        TIDEIN.26
        ZT(J)=ZB2(J)                                                      TIDEIN.27
        TT(J)=TB2(J)                                                      TIDEIN.28
        UT(J)=UB2(J)                                                      TIDEIN.29
        VT(J)=VB2(J)                                                      TIDEIN.30
       ENDDO                                                              TIDEIN.31
       DO I=1,LEN1                                                        TIDEIN.32
        BT(I)=BND2(I)                                                     TIDEIN.33
       ENDDO                                                              TIDEIN.34
      ELSE                                                                TIDEIN.35
       DO J=1,JMAX                                                        TIDEIN.36
        ZT(J)=ZBA(J)                                                      TIDEIN.37
        TT(J)=TBA(J)                                                      TIDEIN.38
        UT(J)=UBA(J)                                                      TIDEIN.39
        VT(J)=VBA(J)                                                      TIDEIN.40
       ENDDO                                                              TIDEIN.41
       DO I=1,LEN1                                                        TIDEIN.42
        BT(I)=BNDA(I)                                                     TIDEIN.43
       ENDDO                                                              TIDEIN.44
      ENDIF                                                               TIDEIN.45
C     ****                                                                TIDEIN.46
C     ****     INTERPOLATE TIDE PERTURBATIONS IN THE LATITUDE             TIDEIN.47
C     ****     DIRECTION                                                  TIDEIN.48
C     ****                                                                TIDEIN.49
      RATIO=NESTRI(LEVEL)                                                 TIDEIN.50
      DO J=1,JNX                                                          TIDEIN.51
       IF(J.EQ.1)THEN                                                     TIDEIN.52
        JJ=NESTJ1(LEVEL)+J-1                                              TIDEIN.53
        ZP(J)=ZT(JJ)                                                      TIDEIN.54
        TP(J)=TT(JJ)                                                      TIDEIN.55
        UP(J)=UT(JJ)                                                      TIDEIN.56
        VP(J)=VT(JJ)                                                      TIDEIN.57
       ELSE                                                               TIDEIN.58
        J2=NESTRI(LEVEL)*(J-1)+1                                          TIDEIN.59
        J1=NESTRI(LEVEL)*(J-2)+1                                          TIDEIN.60
        JJ=NESTJ1(LEVEL)+J-1                                              TIDEIN.61
        ZP(J2)=ZT(JJ)                                                     TIDEIN.62
        TP(J2)=TT(JJ)                                                     TIDEIN.63
        UP(J2)=UT(JJ)                                                     TIDEIN.64
        VP(J2)=VT(JJ)                                                     TIDEIN.65
        DO L=1,NESTRI(LEVEL)-1                                            TIDEIN.66
         ZP(J2-L)=ZP(J2)-DBLE(L)*(ZP(J2)-ZP(J1))/RATIO                    TIDEIN.67
         TP(J2-L)=TP(J2)-DBLE(L)*(TP(J2)-TP(J1))/RATIO                    TIDEIN.68
         UP(J2-L)=UP(J2)-DBLE(L)*(UP(J2)-UP(J1))/RATIO                    TIDEIN.69
         VP(J2-L)=VP(J2)-DBLE(L)*(VP(J2)-VP(J1))/RATIO                    TIDEIN.70
        ENDDO                                                             TIDEIN.71
       ENDIF                                                              TIDEIN.72
      ENDDO                                                               TIDEIN.73
C     ****                                                                TIDEIN.74
C     ****     INTERPOLATE TIDE PERTURBATIONS IN THE LONGITUDE            TIDEIN.75
C     ****     DIRECTION                                                  TIDEIN.76
C     ****                                                                TIDEIN.77
      DO I=1,INX                                                          TIDEIN.78
       IF(I.EQ.1)THEN                                                     TIDEIN.79
        II=NESTI1(LEVEL)+I-1                                              TIDEIN.80
        BP(I)=BT(II)                                                      TIDEIN.81
       ELSE                                                               TIDEIN.82
        I2=NESTRI(LEVEL)*(I-1)+1                                          TIDEIN.83
        I1=NESTRI(LEVEL)*(I-2)+1                                          TIDEIN.84
        II=NESTI1(LEVEL)+I-1                                              TIDEIN.85
        BP(I2)=BT(II)                                                     TIDEIN.86
        DO L=1,NESTRI(LEVEL)-1                                            TIDEIN.87
         BP(I2-L)=BP(I2)-DBLE(L)*(BP(I2)-BP(I1))/RATIO                    TIDEIN.88
        ENDDO                                                             TIDEIN.89
       ENDIF                                                              TIDEIN.90
      ENDDO                                                               TIDEIN.91   
      RETURN                                                              TIDEIN.92
      END                                                                 TIDEIN.93
C                                                                         TIDEIN.94
*DK TWOWAY
      SUBROUTINE N2TWOWAY(S,LEVEL)
      INCLUDE 'n2param.h'
      INCLUDE 'n2const.h'
      INCLUDE 'n2array.h'
      INCLUDE 'n2nestg.h'
      INCLUDE 'nestcnt.h'
      DIMENSION S(INX,NVR,JNX)
C     ****                                                                VDRIFT.3
C     ****     AVERAGE NESTED GRID VALUES (9-POINT) FOR TWO-WAY 
C     ****     INTERACTION                                                VDRIFT.4
C     ****                                                                VDRIFT.6      
      NVRK=NVR
      RATIO=DBLE(NESTRI(LEVEL))
      CON=1./(RATIO*RATIO)
      DO K=1,NVRK
       DO J=2,JNX-1
        JJ=NESTRI(LEVEL)*(J-1)+1
        DO I=2,INX-1
         II=NESTRI(LEVEL)*(I-1)+1
         S(I,K,J)=CON*(G(II,K,JJ)+G(II,K,JJ-1)+G(II,K,JJ+1)+
     1                 G(II-1,K,JJ)+G(II-1,K,JJ-1)+G(II+1,K,JJ+1)+
     2                 G(II+1,K,JJ)+G(II+1,K,JJ-1)+G(II+1,K,JJ+1))
        ENDDO
       ENDDO
      ENDDO
      RETURN
      END
*DK XRAY                                                                    XRAY.1
      SUBROUTINE N2XRAY                                                     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 'n2param.h'                                                   XRAY.7
      INCLUDE 'n2array.h'                                                   XRAY.7
      INCLUDE 'n2cvscr.h'                                                   XRAY.8
      INCLUDE 'n2const.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)+6.7D-1*S1(I,1)                               XRAY.78
       F(I,NQOPK)=F(I,NQOPK)+S2(I,1)+3.3D-1*S1(I,1)                         XRAY.79
       F(I,NQN2PK)=F(I,NQN2PK)+6.4D-1*S3(I,1)                               XRAY.80
       F(I,NQNPK)=F(I,NQNPK)+3.6D-1*S3(I,1)                                 XRAY.81
      ENDDO                                                                 XRAY.82
      RETURN                                                                XRAY.83
      END                                                                   XRAY.84
C                                                                           XRAY.85