SUBROUTINE propdot  
! ----------------------------------------------------------------------
!**** *PROPDOT* - PROPAGATION DOT TERMS FROM DEPTH AND CURRENT GRADIENT.
!     H. GUNTHER   GKSS/ECMWF   17/02/91
!*    PURPOSE.
!     --------
!       COMPUTATION OF COMMON REFDOT FOR PROPAGATION.
!**   INTERFACE.
!     ----------
!       *CALL* *PROPDOT*
!     METHOD.
!     -------
!       IN A LOOP OVER THE BLOCKS THE COMMON UBUF IS READ,
!       THE DEPTH AND CURRENT GRADIENTS ARE COMPUTED,
!       COMMON REFDOT (DEPTH AND CURRENT REFRACTION FOR THETA DOT)
!       IS COMPUTED AND WRITTEN TO MASS STORAGE (IU16).
!       IN CASE OF CURRENT REFRACTION THE COMPLETE SIGMA DOT TERM
!       IS COMPUTED AND WRITTEN TO IU16 ADDITIONALLY.
!       WRITE OPERATIONS ARE NOT DONE FOR COMMON UBUF AND REFDOT
!       IF THIS IS A ONE BLOCK MODEL.
!     EXTERNALS.
!     ----------
!       *GRADI*     - COMPUTES DEPTH AND CURRENT GRADIENTS.
!     REFERENCE.
!     ----------
!       NONE.
! ----------------------------------------------------------------------
use params
use current
use fredir
use gridpar
use map
use refdot
use shallow
use source
use refrsource
use stat
use ubuf
use units
implicit none

REAL    :: DDPHI(NIBLD), DDLAM(NIBLD), DUPHI(NIBLC), DULAM(NIBLC)
REAL    :: DVPHI(NIBLC), DVLAM(NIBLC), DCO(NIBLD), OMDD(NIBLC)
INTEGER :: K,  M,  ID, IG, IJ, JH
REAL    :: CC, CD, SC, SD, SS, XD
! ----------------------------------------------------------------------
!*    1. IF CARTESIAN PROPAGATION SET COSINE OF LAT TO 1.
!         -----------------------------------------------
 1000 CONTINUE  
IF (ICASE.NE.1) THEN  
   DO 1001 IJ = 1, NIBLD  
      DCO (IJ) = 1.  
 1001    END DO  
ENDIF  

!*    2. LOOP OVER BLOCKS.
!        -----------------
IF (IGL.NE.1) REWIND IU08  
DO 2000 IG = 1, IGL  
!*    2.1 IF MULTI BLOCK VERSION.
!         -----------------------
   IF (IGL.NE.1) THEN  
!*    2.1.1 READ COMMON BLOCK UBUF.
!           -----------------------
      READ (IU08) KLAT, KLON  
!SHALLOW
!*    2.1.2 COMPUTE SHALLOW WATER TABLE INDICES.
!           ------------------------------------
      IF (ISHALLO.NE.1) THEN  
         DO 2121 IJ = 1, IJLT (IG)  
            XD = LOG (DEPTH (IJ, IG) / DEPTHA) / LOG (DEPTHD) + 1.
            ID = NINT (XD)  
            ID = MAX (ID, 1)  
            INDEP (IJ) = MIN (ID, NDEPTH)  
 2121          END DO  
      ENDIF  
!SHALLOW
   ENDIF  
!*    2.2 DEPTH AND CURRENT GRADIENTS.
!         ----------------------------
   CALL GRADI (IG, IREFRA, DDPHI, DDLAM, DUPHI, DULAM, DVPHI, DVLAM)
!*    2.3 COSINE OF LATITUDES IF SPHERICAL PROPAGATION.
!         ---------------------------------------------
   IF (ICASE.EQ.1) THEN  
      DO 2301 IJ = IJS (IG), IJL (IG)  
         JH = KXLT (IJ, IG)  
         DCO (IJ) = 1. / COSPH (JH)  
 2301       END DO  
   ENDIF  
!*    2.4 DEPTH GRADIENT PART OF SIGMA DOT.
!         ---------------------------------
   IF (ISHALLO.NE.1.AND.IREFRA.EQ.2) THEN  
      DO 2401 IJ = IJS (IG), IJL (IG)  
         OMDD (IJ) = V (IJ, IG) * DDPHI (IJ) + U (IJ, IG) * DDLAM(IJ) * DCO (IJ)
 2401       END DO  
   ENDIF  
!*    2.5. LOOP OVER DIRECTIONS.
!          ---------------------
   DO 2501 K = 1, NANG  
      SD = SINTH (K)  
      CD = COSTH (K)  
!*    2.5.1. DEPTH GRADIENT OF THETA DOT.
!            ----------------------------
      IF (ISHALLO.NE.1) THEN  
         DO 2511 IJ = IJS (IG), IJL (IG)  
            THDD (IJ, K) = SD * DDPHI (IJ) - CD * DDLAM (IJ) * DCO (IJ)
 2511          END DO  
      ENDIF  
!*    2.5.2 SIGMA DOT AND THETA DOT PART FROM CURRENT GRADIENT.
!           ---------------------------------------------------
      IF (IREFRA.EQ.2) THEN  
         SS = SD**2  
         SC = SD * CD  
         CC = CD**2  
         DO 2521 IJ = IJS (IG), IJL (IG)  
            SL_REFR (IJ, K, NFRE) = - SC * DUPHI (IJ) - CC * &
             DVPHI (IJ) - (SS * DULAM (IJ) + SC * DVLAM (IJ) ) &
             * DCO (IJ)
            THDC (IJ, K) = SS * DUPHI (IJ) + SC * DVPHI (IJ) &
             - (SC * DULAM (IJ) + CC * DVLAM (IJ) ) * DCO (IJ)
 2521          END DO  
!*    2.5.3 LOOP OVER FREQUENCIES.
!           ----------------------
         IF (ISHALLO.NE.1) THEN  
            DO 2530 M = 1, NFRE  
               DO 2531 IJ = IJS (IG), IJL (IG)  
                  SL_REFR (IJ, K, M) = (SL_REFR (IJ, K, NFRE) &
                   * TCGOND (INDEP (IJ), M) + OMDD (IJ) * TSIHKD ( &
                   INDEP (IJ), M) ) * TFAK (INDEP (IJ), M)
 2531                END DO  
!*    BRANCH BACK TO 2.5.3 FOR NEXT FREQUENCY.
 2530             END DO  
         ENDIF  
      ENDIF  
!*    BRANCH BACK TO 2.5 FOR NEXT DIRECTION.
 2501    END DO  
!*    BRANCH BACK TO 2. FOR NEXT BLOCK.
2000 END DO  

RETURN  
END SUBROUTINE propdot
