#include "dims.h"
      SUBROUTINE STENMOD(IMX,JMX,C,PHIHM,P,COLATC)
      implicit none
C     ****
C     ****     MODIFY STENCIL TO SET POTENTIAL TO HEELIS VALUE
C     ****       WITHIN AURORAL CIRCLE
C     ****
#include "params.h"
#include "consdyn.h"
!
! Args:
      integer,intent(in) :: imx,jmx
      real,intent(out) :: C(IMX,JMX,*)
      real,intent(in)  :: PHIHM(IMX0,JMX0),COLATC(IMX0,JMX0),
     |                    P(IMX0,JMX0)
!
! Local:
      integer :: nint,i0,j0,i,j,n,jj
C     ****
C     ****     COMPUTE SEPARATION OF GRID POINTS FOR THIS RESOLUTION
C     ****
      NINT = (IMX0-1)/(IMX-1)
      I0 = 1-NINT
      J0 = 1-NINT
C     ****
C     ****     IF (NINT.EQ.1), WE ARE AT HIGHEST RESOLUTION.
C     ****       CORRECT RHS, WHICH IS IN C(10)
C     ****
      IF(NINT.EQ.1)THEN
        DO 3 J = 1,JMX
          DO 3 I = 1,IMX
            C(I,J,10) = P(I,J)*C(I,J,10)+(1.-P(I,J))*C(I,J,9)*
     1        (DLATM/(10.*DTR))**2*PHIHM(I,J)
    3   CONTINUE
      ENDIF
C     ****
C     ****     MODIFY STENCIL, C(I,J,N),N=1,9)
C     ****
      DO 1 J = 1,JMX
        JJ = J0+J*NINT
        DO 2 N = 1,8
          DO 2 I = 1,IMX
            C(I,J,N) = C(I,J,N)*P(I0+I*NINT,JJ)

!           write(6,"('stenmod: i=',i3,' n=',i2,' j=',i3,' c=',e12.4, 
!    |        ' pfrac=',e12.4)") i,n,j,c(i,j,n),p(i0+i*nint,jj) 

    2   CONTINUE
        DO 4 I = 1,IMX
          C(I,J,9) = C(I,J,9)*P(I0+I*NINT,JJ)+(1.-P(I0+I*NINT,JJ))*
     1      C(I,J,9)*(DLATM*FLOAT(NINT)/(10.*DTR))**2
    4 CONTINUE
    1 CONTINUE
      RETURN
      END
C