CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C        This file contains the subroutines which correspond       C
C        to those in slgcm.F in the 3D model, except the routine   C
C        called SLGCST.                                            C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE FIPOLE(WIN,FI,VIN,ANGIN,SPOLE)
      include "slgcm.slgprm"
      DIMENSION  WIN(IMP3,JMP3), FI(IMP3,JM)
C
      LOGICAL SPOLE
C
      GL1ST = ANGIN
      IF (SPOLE) THEN
         PH1ST = -PIO2 + VIN
         IF (PH1ST .LE. -PIO2 + DPH*0.05) THEN
             FIP = WIN(1,3)
            GO TO 101
         ENDIF
      ELSE
         PH1ST =  PIO2 - VIN
         IF (PH1ST .GE. PIO2 - DPH*0.05) THEN
            FIP = WIN(1,JMP2)
            GO TO 101
         ENDIF
      ENDIF
C
      XGL1ST = (GL1ST+DLM)*RDLM
      XPH1ST = (PH1ST+PIO2)*RDPH + 3
C
C     IF (IPR .LE. 1 .OR. IPR .GE. IMP2 .OR. JPR .LE. 1 .OR.
C    *    JPR .GE. JMP2) PRINT *,' IN FIPOLE IPR=',IPR,' JPR=', JPR
C     PRINT *,' IN FIPOLE IPR=',IPR,' JPR=', JPR
C
      IF (.NOT. TRICUB) THEN
         IPR    = XGL1ST + 0.5
         JPR    = XPH1ST + 0.5
         BTPR   = XPH1ST-JPR
         ALPR   = XGL1ST-IPR
         IF (IPR .EQ. 1) IPR = IMP1
         IPRP1  = IPR + 1
         JPRP1  = JPR + 1
         IPRM1  = IPR - 1
         JPRM1  = JPR - 1
         TEM1   = 1.0 - ALPR
         TEM2   = 1.0 + ALPR
         C1A =  - ALPR * TEM1 * 0.5
         C2A =    TEM1 * TEM2
         C3A =    ALPR * TEM2 * 0.5
C
         TEM1   = 1.0 - BTPR
         TEM2   = 1.0 + BTPR
         C1B =  - BTPR * TEM1 * 0.5
         C2B =    TEM1 * TEM2
         C3B =    BTPR * TEM2 * 0.5
C
         FIP =  C1A*(C1B*WIN(IPRM1,JPRM1 ) + C2B*WIN(IPRM1,JPR )
     *             + C3B*WIN(IPRM1,JPRP1 ))
     *       +  C2A*(C1B*WIN(IPR  ,JPRM1 ) + C2B*WIN(IPR  ,JPR )
     *             + C3B*WIN(IPR  ,JPRP1 ))
     *       +  C3A*(C1B*WIN(IPRP1,JPRM1 ) + C2B*WIN(IPRP1,JPR )
     *             + C3B*WIN(IPRP1,JPRP1 ))
      ELSE
         IPR    = XGL1ST
         JPR    = XPH1ST
         BTPR   = XPH1ST-JPR
         ALPR   = XGL1ST-IPR
         IF (IPR .EQ. 1) IPR = IMP1
         IPRP1  = IPR + 1
         JPRP1  = JPR + 1
         IPRM1  = IPR - 1
         JPRM1  = JPR - 1
         ALPRSQ = ALPR*ALPR
         BTPRSQ = BTPR*BTPR
         IPRP2  = IPR + 2
         JPRP2  = JPR + 2
         TWOMAL = (2.-ALPR) * 0.5
         TWOMBT = (2.-BTPR) * 0.5
         ONMASQ = 1. - ALPRSQ
         ONMBSQ = 1. - BTPRSQ
C
C
         C1A = ONMASQ*TWOMAL
         C2A = (ALPRSQ+ALPR)*TWOMAL
         C3A = THIRD*(ALPRSQ-ALPR)*TWOMAL
         C4A = SIXTH*ONMASQ*(-ALPR)
C
         C1B = ONMBSQ*TWOMBT
         C2B = (BTPRSQ+BTPR)*TWOMBT
         C3B = THIRD*(BTPRSQ-BTPR)*TWOMBT
         C4B = SIXTH*ONMBSQ*(-BTPR)
C
         FIP  = C1A*(C1B*WIN(IPR  ,JPR   ) + C2B*WIN(IPR  ,JPRP1 )
     *             + C3B*WIN(IPR  ,JPRM1 ) + C4B*WIN(IPR  ,JPRP2 ))
     *        + C2A*(C1B*WIN(IPRP1,JPR   ) + C2B*WIN(IPRP1,JPRP1 )
     *             + C3B*WIN(IPRP1,JPRM1 ) + C4B*WIN(IPRP1,JPRP2 ))
     *        + C3A*(C1B*WIN(IPRM1,JPR   ) + C2B*WIN(IPRM1,JPRP1 )
     *             + C3B*WIN(IPRM1,JPRM1 ) + C4B*WIN(IPRM1,JPRP2 ))
     *        + C4A*(C1B*WIN(IPRP2,JPR   ) + C2B*WIN(IPRP2,JPRP1 )
     *             + C3B*WIN(IPRP2,JPRM1 ) + C4B*WIN(IPRP2,JPRP2 ))
C
C     ELSE
c        FIP = ALPR*(BTPR*WIN(IPRP1,JPRP1) + (1.0-BTPR)*WIN(IPRP1,JPR))
c    *   + (1-ALPR)*(BTPR*WIN(IPR  ,JPRP1) + (1.0-BTPR)*WIN(IPR,  JPR))
      ENDIF
  101 CONTINUE
C
      IF (SPOLE) THEN
         DO 310 I=1,IMP3
         FI(I,1) = FIP
  310    CONTINUE
      ELSE
         DO 320 I=1,IMP3
         FI(I,JM) = FIP
  320    CONTINUE
      ENDIF
C
      RETURN
      END
        SUBROUTINE VPOLE (IMx, DLM, TWOPI, TWOOIM, PIFAC
     *,                  VIN, CLAM, SLAM, VOUT, ANGOUT)
C
        DIMENSION  VIN(IMx),CLAM(IMx),SLAM(IMx)
        dimension  WKA(1000),WKB(1000)
C
        SUMVCS = 0.0
        SUMVSN = 0.0
        DO 10 I=1,IMx
        WKA(I) = VIN(I) * CLAM(I)
        WKB(I) = VIN(I) * SLAM(I)
   10   CONTINUE
        DO 20 I=1,IMx
        SUMVCS    = SUMVCS + WKA(I)
        SUMVSN    = SUMVSN + WKB(I)
   20   CONTINUE
        SUMVCS    = SUMVCS * TWOOIM
        SUMVSN    = SUMVSN * TWOOIM
C
C
        IF (SUMVCS .NE. 0.0) THEN
           DEL   = ATAN2(SUMVSN,SUMVCS) + PIFAC
       ELSEIF (SUMVSN .GT. 0.0) THEN
           DEL    = TWOPI * 0.25 + PIFAC
       ELSE
           DEL    = - TWOPI * 0.25 + PIFAC
       ENDIF
       VOUT  = SQRT(SUMVCS*SUMVCS+SUMVSN*SUMVSN)
C
C  REDEFINE LAM* SUCH THAT DLM < LAM* < (TWOPI+DLM).
C
        RATIO  = (DEL-DLM)/TWOPI
        IRATIO = RATIO
        IF (RATIO .LT. 0) IRATIO = IRATIO-1
        RESULT = (RATIO-IRATIO)*TWOPI
        ANGOUT = RESULT + DLM
  100   CONTINUE
C
        RETURN
        END
      SUBROUTINE FILPU(UFILL)
C
C*********************************************************************
C  FILL IN THE 'GHOST' VALUES AT U - POINTS J=1 AND J=JM
C*********************************************************************
C
      include "slgcm.slgprm"
      include "slgcm.slgclm"
C
      DIMENSION UFILL(IJM0M0)

      annp = 0.0
      bnnp = 0.0
      ansp = 0.0
      bnsp = 0.0
      DO 20 I=1,IM
      annp = annp + ufill(ijm2m0+i) * clm(i,1)
      bnnp = bnnp + ufill(ijm2m0+i) * slm(i,1)
      ansp = ansp + ufill(i+i1)     * clm(i,1)
      bnsp = bnsp + ufill(i+i1)     * slm(i,1)
 20   CONTINUE
      annp = annp * twooim
      bnnp = bnnp * twooim
      ansp = ansp * twooim
      bnsp = bnsp * twooim
      do 30 i=1,im
      ufill(i)        = ansp * clm(i,1) + bnsp * slm(i,1)
      ufill(i+ijm1m0) = annp * clm(i,1) + bnnp * slm(i,1)
  30  continue
C
      UFILL(IMP1) = UFILL(1)
      UFILL(IMP2) = UFILL(2)
      UFILL(IMP3) = UFILL(3)
      UFILL(IMP1+IJM1M0) = UFILL(1+IJM1M0)
      UFILL(IMP2+IJM1M0) = UFILL(2+IJM1M0)
      UFILL(IMP3+IJM1M0) = UFILL(3+IJM1M0)
C

      RETURN
      END
        SUBROUTINE FILPV(VFILL)
C
C*********************************************************************
C  FILL IN THE 'GHOST' VALUES AT V - POINTS J=JM
C*********************************************************************
C
      include "slgcm.slgprm"
C
        DIMENSION VFILL(IJM0M0)
C
        DO 10 I=1,IMB2
        VFILL(IJM1M0+I)      = - VFILL(IJM2M0+I+IMB2)
        VFILL(IJM1M0+I+IMB2) = - VFILL(IJM2M0+I)
   10   CONTINUE
C
        VFILL(IJM1M0+IMP1) = VFILL(IJM1M0+1)
        VFILL(IJM1M0+IMP2) = VFILL(IJM1M0+2)
        VFILL(IJM1M0+IMP3) = VFILL(IJM1M0+3)
C
        RETURN
        END
        SUBROUTINE FILLV(VFILL)
C
C*********************************************************************
C  FILL IN THE 'GHOST' VALUES AT V - POINTS J=1,2 and J=JMP2,JMP3
C*********************************************************************
C
      include "slgcm.slgprm"
C
        DIMENSION VFILL(IMP3,JMP3)
C
C
        DO 10 I=1,IMB2
        VFILL(I,1   ) = - VFILL(I+IMB2,4   )
        VFILL(I,2   ) = - VFILL(I+IMB2,3   )
        VFILL(I,JMP2) = - VFILL(I+IMB2,JMP1)
        VFILL(I,JMP3) = - VFILL(I+IMB2,JM  )
C
        VFILL(I+IMB2,1   ) = - VFILL(I,4   )
        VFILL(I+IMB2,2   ) = - VFILL(I,3   )
        VFILL(I+IMB2,JMP2) = - VFILL(I,JMP1)
        VFILL(I+IMB2,JMP3) = - VFILL(I,JM  )
   10   CONTINUE
C
        VFILL(IMP1,1   ) = VFILL(1,1   )
        VFILL(IMP2,1   ) = VFILL(2,1   )
        VFILL(IMP3,1   ) = VFILL(3,1   )
        VFILL(IMP1,2   ) = VFILL(1,2   )
        VFILL(IMP2,2   ) = VFILL(2,2   )
        VFILL(IMP3,2   ) = VFILL(3,2   )
        VFILL(IMP1,JMP2) = VFILL(1,JMP2)
        VFILL(IMP2,JMP2) = VFILL(2,JMP2)
        VFILL(IMP3,JMP2) = VFILL(3,JMP2)
        VFILL(IMP1,JMP3) = VFILL(1,JMP3)
        VFILL(IMP2,JMP3) = VFILL(2,JMP3)
        VFILL(IMP3,JMP3) = VFILL(3,JMP3)
C
        RETURN
        END
      SUBROUTINE FILLU(UFILL)
C
C*********************************************************************
C  FILL IN THE 'GHOST' VALUES AT U - POINTS J=1,2,3 and J=JMP2,JMP3
C*********************************************************************
C
      include "slgcm.slgprm"
C
      DIMENSION UFILL(IMP3,JMP3)
C
      DO 10 I=1,IMB2
      UFILL(I,   1) = -UFILL(I+IMB2,5)
      UFILL(I,   2) = -UFILL(I+IMB2,4)
      UFILL(I,JMP3) = -UFILL(I+IMB2,JMP1)
C
      UFILL(I+IMB2,   1) = -UFILL(I,5)
      UFILL(I+IMB2,   2) = -UFILL(I,4)
      UFILL(I+IMB2,JMP3) = -UFILL(I,JMP1)
   10 CONTINUE
C
      UFILL(IMP1,1   ) = UFILL(1,1   )
      UFILL(IMP2,1   ) = UFILL(2,1   )
      UFILL(IMP3,1   ) = UFILL(3,1   )
      UFILL(IMP1,2   ) = UFILL(1,2   )
      UFILL(IMP2,2   ) = UFILL(2,2   )
      UFILL(IMP3,2   ) = UFILL(3,2   )
c
      UFILL(IMP1,JMP3) = UFILL(1,JMP3)
      UFILL(IMP2,JMP3) = UFILL(2,JMP3)
      UFILL(IMP3,JMP3) = UFILL(3,JMP3)
C
      RETURN
      END
      SUBROUTINE FILLP(FI)
C
C*********************************************************************
C  FILL IN THE 'GHOST' VALUES AT PHI - POINTS J=1,2 and J=JMP3
C*********************************************************************
C
      include "slgcm.slgprm"
C
      DIMENSION FI(IJP3M0)
C
      DO 10 I=1,IMB2
      FI(I)        = FI(I+IMB2+I4)
      FI(I1+I)     = FI(I+IMB2+I3)
      FI(I+IJP2M0) = FI(I+IMB2+IJM0M0)
C
      FI(I+IMB2)        = FI(I+I4)
      FI(I+IMB2+I1)     = FI(I+I3)
      FI(I+IMB2+IJP2M0) = FI(I+IJM0M0)
   10 CONTINUE
C
      FI(IMP1)     = FI(1   )
      FI(IMP2)     = FI(2   )
      FI(IMP3)     = FI(3   )
      FI(IMP1+I1   )  = FI(1+I1  )
      FI(IMP2+I1   )  = FI(2+I1  )
      FI(IMP3+I1   )  = FI(3+I1  )
      FI(IMP1+IJP2M0) = FI(1+IJP2M0)
      FI(IMP2+IJP2M0) = FI(2+IJP2M0)
      FI(IMP3+IJP2M0) = FI(3+IJP2M0)
C
      RETURN
      END
