SUBROUTINE intpol (f3, f1, ijs, ijl, ig)  
! ----------------------------------------------------------------------
!**** *INTPOL* - TRANSFORMATION OF SPECTRA FROM SIGMA TO OMEGA.
!     S.D.HASSELMANN      MPI            1.1.91
!     H. GUNTHER          GKSS/ECMWF     1.2.91  MODIFIED FOR CYCLE_4
!
!*    PURPOSE.
!     --------
!       TRANSFORMATION OF A MOVING COORDINATE SYSTEM TO AN ABSOLUTE
!       COORDINATE SYSTEM.
!**   INTERFACE.
!     ----------
!       *CALL* *INTPOL (F3, F1, IJS, IJL, IG)*
!         *F3*   - BLOCK OF SPECTRA (INPUT).
!         *F1*   - BLOCK OF SPECTRA (OUTPUT).
!         *IJS*  - INDEX OF FIRST GRIDPOINT.
!         *IJL*  - INDEX OF LAST GRIDPOINT.
!         *IG*   - BLOCK NUMBER.
!     METHOD.
!     -------
!       SCATTERING TO NEIGHBOURING POINT.
!     EXTERNALS.
!     ----------
!       NONE.
!     REFERENCE.
!     ----------
!       NONE.
! ----------------------------------------------------------------------
use params  
use current
use fredir
use shallow
use stat
implicit none

REAL   ,INTENT(IN) :: f3(0:niblo,nang,nfre)
REAL   ,INTENT(OUT):: f1(0:niblo,nang,nfre)
INTEGER,INTENT(IN) :: ijs, ijl, ig
INCLUDE'globals.h'

REAL,PARAMETER :: CO=1.1, ALN00=24.1589,FRE0=CO-1.,PI2G=ZPI/G
!*     VARIABLE.   TYPE.     PURPOSE.
!      ---------   -------   --------
!        *CO*      REAL      FREQUENCY RATIO.
!        *ALN00*   REAL      1. / LOG10(CO)
REAL   :: FNEF(NIBLC), GWP(NIBLC), GWM(NIBLC), WAVN(NIBLC)
INTEGER:: NEWF(NIBLC), NEWF1(NIBLC), KNEW(NIBLC)
INTEGER:: IJ, KH, M, K, NEWM, NEWM1
REAL   :: GWH, FNEW!NIKOS, NEWM, NEWM1

! ----------------------------------------------------------------------
!*    0. INITIAL OUTPUT ARRAY WITH ZERO.
!        -------------------------------
DO M = 1, NFRE  
   DO K = 1, NANG  
      DO IJ = 0, NIBLO  
         F1 (IJ, K, M) = 0.0  
      ENDDO
   ENDDO
ENDDO

!*    1. LOOP OVER FREQUENCIES.
!        ----------------------
DO 1000 M = 1, NFRE  
   IF (ISHALLO.NE.1) THEN  
      DO 1201 IJ = IJS, IJL  
         WAVN (IJ) = TFAK (INDEP (IJ), M) / ZPI  
 1201       END DO  
   ELSE  
      DO 1202 IJ = IJS, IJL  
         WAVN (IJ) = PI2G * FR (M) * FR (M)  
 1202       END DO  
   ENDIF  
!*    1.3 LOOP OVER DIRECTONS.
!         --------------------
   DO 1301 K = 1, NANG  
!*    1.3.1 NEW FREQUENCY AND DIRECTION AT ALL GRIDPOINTS.
!           ----------------------------------------------
      DO 1311 IJ = IJS, IJL  
         FNEF (IJ) = FR (M) + WAVN (IJ) * (COSTH (K) * V (IJ, IG) &
          + SINTH (K) * U (IJ, IG) )
         IF (FNEF (IJ) .GT.0.) THEN  
            KNEW (IJ) = K  
         ELSE  
            KNEW (IJ) = MOD (K + NANG / 2 - 1, NANG) + 1  
            FNEF (IJ) = - FNEF (IJ)  
         ENDIF  
 1311       END DO  
!*    1.3.2 NEW FREQUENCY BIN NUMBER AT ALL GRIDPOINTS.
!           -------------------------------------------
!
      DO 1321 IJ = IJS, IJL  
         IF (FNEF (IJ) .LE.FR (1) / CO) THEN  
            NEWF (IJ) = - 1  
         ELSE  
            NEWF (IJ) = INT (LOG10 (FNEF (IJ) / FR (1) ) * ALN00 + &
             1.000000001)
         ENDIF  
 1321       END DO  
!
!*    1.3.3 INTERPOLATED ENERGY DENSITIES AT ALL GRIDPOINTS.
!           ------------------------------------------------
!
      DO 1331 IJ = IJS, IJL  
         FNEW = FNEF (IJ)  
         NEWM = NEWF (IJ)  
         IF (NEWM.LT.NFRE.AND.NEWM.GE.1) THEN  
            NEWM1 = NEWM + 1  
            GWH = DFIM (M) / (FR (NEWM1) - FR (NEWM) ) * F3 (IJ, K, M)
            GWM (IJ) = GWH * (FR (NEWM1) - FNEW) / DFIM (NEWM)  
            GWP (IJ) = GWH * (FNEW - FR (NEWM) ) / DFIM (NEWM1)  
            NEWF1 (IJ) = NEWM1  
         ELSEIF (NEWM.EQ.0) THEN  
            GWH = CO * DFIM (M) / (FRE0 * FR (1) ) * F3 (IJ, K, M)  
            GWP (IJ) = GWH * (FNEW - FR (1) / CO) / DFIM (1)  
            NEWF (IJ) = - 1  
            NEWF1 (IJ) = 1  
         ELSEIF (NEWM.EQ.NFRE) THEN  
            GWH = DFIM (M) / (FRE0 * FR (NFRE) ) * F3 (IJ, K, M)  
            GWM (IJ) = GWH * (CO * FR (NFRE) - FNEW) / DFIM (NFRE)  
            NEWF1 (IJ) = - 1  
         ELSE  
            NEWF (IJ) = - 1  
            NEWF1 (IJ) = - 1  
         ENDIF  
 1331       END DO  
!*    1.3.4 NEW SPECTRUM AT ALL GRIDPOINTS.
!           -------------------------------
      DO IJ = IJS, IJL  
         NEWM = NEWF (IJ)  
         NEWM1 = NEWF1 (IJ)  
         KH = KNEW (IJ)  
         IF (NEWM.NE. - 1) F1 (IJ, KH, NEWM)   = F1 (IJ, KH, NEWM) + GWM(IJ)
         IF (NEWM1.NE. - 1) F1 (IJ, KH, NEWM1) = F1 (IJ,KH,NEWM1)  + GWP(IJ)
      END DO  
!*    BRANCH BACK TO 1.3 FOR NEXT DIRECTION.
 1301    END DO  
!*    BRANCH BACK TO 1. FOR NEXT FREQUENCY.

 1000 END DO  
RETURN  
END SUBROUTINE intpol
