C  MODE.FOR
C **********************************************************************
      SUBROUTINE MODE(*,
     & EK, C0, Z0, C1, Z1, ISO,
     & MY, MAXMSH, MODEN,
     & ADA, SPEED, ZZ, Z0NRM, Z1NRM )


      INTEGER EXTPOL
      INTEGER ALEFT, ARIGHT, CURRNT
      INTEGER FIXDZ, OPTMZ
      REAL ETIME, CPSEC(2)
      REAL CPUBEG, CPUEND, CPEIGV, CPEIGF, CPNEWP, CPFILE

C      CHARACTER*8 MODEL


      DOUBLE PRECISION CC0, CC1, CMIN, H0, H1, ROB, ROS
      DOUBLE PRECISION TWOPI, PI, FRQ, OMEGA
      DOUBLE PRECISION EK(MODEN)
      DOUBLE PRECISION ADA( * ), SPEED( * )
      DOUBLE PRECISION ISO(MODEN), MY(MAXMSH,MODEN)
      DOUBLE PRECISION ZZ( * )
      DOUBLE PRECISION Z0NRM(*), Z1NRM(*)
      DOUBLE PRECISION C0(*), C1(*), Z0(*), Z1(*)


      COMMON /AB/ BETA(-1:3), SCATT(2), C2S, CC0, CC1, C2
      COMMON /APM/ NSMPL, NSMDEF
      COMMON /DENS/ R0, R1, R2
      COMMON /DENS8/ ROB, ROS
      COMMON /FACTS/ FACT0, FACT1, FLAGF0, FLAGF1
      COMMON /FLAGPL/ FIRST, FLAGP, FLAGPU, EXTPOL, CORREC
      COMMON /FRQDEP/ FRQREF, FPOW, FRQDEP
      COMMON /G/ H0, H1
      COMMON /LUNIT/ LUPLP, LUPLT, LUPRT
      COMMON /MESH/ DZH0, DZH1, INPDZ, FIXDZ
C      COMMON /MODEL/ MODEL
      COMMON /N/ MINMOD, MAXMOD, MODCUT, HBEAM, BPHVEL
      COMMON /NA/ ND0, ND1, CMIN
      COMMON /PARA4/ NMAM2, NPAM2
      COMMON /PARAM1/ ISECT, IFREQ, JUMP, MODQTY
      COMMON /PARAM2/ FRQ, EPSINP
      COMMON /PARAM3/ IMESH, NMESH, MSHRAT, OPTMZ
      COMMON /POSITN/ ALEFT, ARIGHT, CURRNT
      COMMON /RNGPRF/ NSECT, RKM
      COMMON /TIMING/ CPEIGV, CPEIGF, CPNEWP, CPFILE
      COMMON /TRIGON/ TWOPI, PI, OMEGA

  230 FORMAT(1H1 ,/,'  FREQUENCY NO. ',I3,/,'  ****************',///)
  240 FORMAT(1H ,' SAMPLE POINTS/MODE:',12X,'=',I6,//)
  242 FORMAT(1H ,' SAMPLING STEP IN DEPTH (m):',/,
     &'  WATER',11X,'=',F8.2,/,'  SEDIMENT',8X,'=',F8.2,//)
  250 FORMAT(1H ,' DEPTHS (m):',/,'  WATER',11X,'=',F8.2,
     & /,'  SEDIMENT',8X,'=',F8.2,//)
  260 FORMAT(1H ,' DENSITIES (g/cm**3):',/,'  WATER',11X,'=',F8.2,
     & /,'  SEDIMENT',8X,'=',F8.2,/,'  SUBBOTTOM',7X,'=',F8.2,//)
  261 FORMAT(1H ,' DENSITIES (g/cm**3):',/,'  WATER',11X,'=',1PE13.5,/
     & ,'  SEDIMENT',8X,'=',1PE13.5,/,'  SUBBOTTOM',7X,'=',1PE13.5,//)  
  270 FORMAT(3X,F8.2,4X,F8.2)                                           
  280 FORMAT(1H ,/ /,5X,'SOUND SPEED PROFILE',//,11X,' WATER     ',//,
     & '    DEPTH (m)  SPEED (m/s)  ')                                     
  290 FORMAT(1H ,///,'          SEDIMENT ',                             
     & //,'    DEPTH (m)  SPEED (m/s)')                                  
  301 FORMAT(1X,/,'  FILE ',A20,' ALREADY EXISTS ',/)                   
  400 FORMAT(1X ,///,'  WARNING: ',/,'  THIS "C-SNAP" VERSION IS',       
     & '  CURRENTLY RUNNING A RANGE INDEPENDENT PROBLEM.',/,            
     & '  IN THIS CASE IT ALLOWS FOR A MAXIMUM OF ',I4,' MODES',/,      
     & '  COMPUTED OVER A MAXIMUM OF ',I5,' MESH POINTS',//)            
  420 FORMAT(1X ,///,'  WARNING: ',/,'  THIS "C-SNAP" VERSION IS',       
     & '  CURRENTLY RUNNING A RANGE DEPENDENT PROBLEM.',/,              
     & '  IN THIS CASE IT ALLOWS FOR A MAXIMUM OF ',I4,' MODES',/,      
     & '  COMPUTED OVER A MAXIMUM OF ',I5,' MESH POINTS',//)            
  600 FORMAT(1H ,//,' BOTTOM SOUND SPEED   =',F8.2,' m/s',/             
     & ,' SHEAR SPEED',10X,'=',F8.2,' m/s',/)                            
  601 FORMAT(1H ,//,' BOTTOM SOUND SPEED   =',1PE13.5,' m/s',/          
     & ,' SHEAR SPEED',10X,'=',1PE13.5,' m/s',/)                         
  700 FORMAT(1H ,' ATTENUATION COEFFICIENTS (dB/WL): ',                 
     &        /,'  SEDIMENT',8X,'=',F8.2,/,'  SUBBOTTOM',7X,'=',F8.2,   
     & /,'  SHEAR  ',9X,'=',F8.2,///,'  RMS ROUGHNESSES (m):',5X,/,     
     & '  SEA SURFACE',5X,'=',F8.2,/,'  SEA FLOOR',7X,'=',F8.2,////)    
  701 FORMAT(1H ,' ATTENUATION COEFFICIENTS (dB/WL): ',                 
     &     /,'  SEDIMENT',8X,'=',1PE13.5,/,'  SUBBOTTOM',7X,'=',1PE13.5,
     & /,'  SHEAR  ',9X,'=',1PE13.5,///,'  RMS ROUGHNESSES (m):',5X,/,  
     & '  SEA SURFACE',5X,'=',1PE13.5,/,'  SEA FLOOR',7X,'=',1PE13.5,   
     & ////)                                                            
C  830 FORMAT(1H ,///,'  ***  Computing modes for profile # ',I5,/,      
C     & '  Range           ',F9.3,' km',/,                               
C     & '  Water depth    ',f9.2,'  m',/,                                
C     & '  Sediment depth ',f9.2,'  m',/)                                
 830  FORMAT(1H ,///,'  ***  Profile #',I5,' - Range',F9.3,'km',
     & ' - H0',f9.2,'m',' -  H1',f9.2,'m')                                
                                                                        
      CPUBEG= ETIME(CPSEC)                                        
                                                                        
      MAXMOD=MIN(MAXMOD,MODEN-2)                                        
                                                                        
      IF(FLAGP.LT.0.0)   THEN                                           
        WRITE(LUPRT,400) NMAM2, NPAM2                                       
        FLAGP=1.0                                                       
      END IF                                                            
                                                                        
      OMEGA=TWOPI*FRQ                                                   
                                                                        
C                                                                       
C   INPUT PARAMETERS WERE READ FROM FILE 10                             
C                                                                       
                                                                        
C   R0 IS DENSITY OF  WATER LAYER.                                      
      R0=1.                                                             
      IF(EPSINP.LT.0.0)   GO TO 1100                                    
      IF( (FLAGPU .LT. 1.)  .AND. (FIRST .EQ. 0.0 ) ) 
     &  WRITE(LUPRT,230) IFREQ                           
 1100 CONTINUE
                                                                        
       FRQDEP= 1
       IF( FRQ .LE. FRQREF )   FRQDEP= ( FRQ/FRQREF)**FPOW

      BETA(0)= BETA(-1) * 1.0D-3 * CC0/FRQ                              
COLD  BETA(0)= FRQ*1.0E-9*(.007+.2635/(2.89+(FRQ*.001)**2))*CC0         
      IF(JUMP .GT. 0)   GO TO 1200                                      
        IF(INPDZ .EQ. 0)   THEN                                         
          WRITE(LUPRT,240) NSMPL                                            
        ELSE                                                            
          DZSED= MIN( DZH1, SNGL(H1) )                                  
          WRITE(LUPRT,242) DZH0, DZSED                                      
        END IF                                                          
        WRITE(LUPRT,250) H0,H1                                              
        IF( MAX(R0,R1,R2) .LE. 99999.99 )   THEN                        
         WRITE(LUPRT,260) R0,R1,R2                                          
        ELSE                                                            
         WRITE(LUPRT,261) R0,R1,R2                                          
        END IF                                                          
                                                                        
        IF( MAX(BETA(1),BETA(2),BETA(3),SCATT(1),SCATT(2)) .LE.         
     &   99999.99 )   THEN                                              
         WRITE(LUPRT,700) FRQDEP*BETA(1), BETA(2), BETA(3),
     &                    (SCATT(J), J=1, 2)
        ELSE                                                            
         WRITE(LUPRT,701) FRQDEP*BETA(1), BETA(2), BETA(3),
     &                    (SCATT(J), J=1, 2)
        END IF                                                          
 1200 CONTINUE                                                          
                                                                        
C   MIN SOUND SPEED                                                     
      CMIN=1.0D38                                                       
      DO 1260   I=1,ND0                                                 
      CMIN=MIN(CMIN,C0(I))                                              
 1260 CONTINUE                                                          
      CORREC= -1                                                        
      IF(H1.GT.0.0)   THEN                                              
        DO 1300   I=1,ND1                                               
        CMIN=MIN(CMIN,C1(I))                                            
 1300   CONTINUE                                                        
      ELSE                                                              
                                                                        
C**C  N.B. This correction perturbs the accuracy of the mode coupling   
C**C       when the contribution from the mode tail is computed.        
C**C       It may be useful only for range independent calculations.    
C  REMOVED ON 26 JAN '93 : MORE PROBLEMS THAN ADVANTAGES                
C        IF(MODEL(1:6) .EQ. 'C-SNAP')   CORREC= 1.0                     
                                                                        
      END IF                                                            
                                                                        
      IF(FLAGF1 .GT. 0.)   CORREC=-1.                                   
                                                                        
C   BOTTOM                                                              
      IF(JUMP.GT.0)   GO TO 1400                                        
      WRITE(LUPRT,280)                                                      
      WRITE(LUPRT,270) (Z0(I),C0(I),I=1,ND0)                                
      IF(H1.LE.0.0)   GO TO 1350                                        
      WRITE(LUPRT,290)                                                      
      WRITE(LUPRT,270) (Z1(I),C1(I),I=1,ND1)                                
 1350 CONTINUE                                                          
      IF( MAX(C2,C2S) .LE. 99999.99 )   THEN                            
       WRITE(LUPRT,600) C2,C2S                                              
      ELSE                                                              
       WRITE(LUPRT,601) C2,C2S                                              
      END IF                                                            
 1400 CONTINUE                                                          
                                                                        
                                                                        
C     NORMALIZATION OF DEPTHS                                           
                                                                        
      DO 1450   I=1,ND0                                                 
      Z0NRM(I)=Z0(I)/H0                                                 
 1450 CONTINUE                                                          
      DO 1500   I=1,ND1                                                 
      Z1NRM(I)=(H0+Z1(I))/H0                                            
 1500 CONTINUE                                                          
                                                                        
      IF(FLAGPU .LT. 1)   WRITE(LUPRT,830) ISECT, RKM, H0, H1
                                                                        
C ******************************************************************** 
      ITEMP= ALEFT                                                     
      ALEFT= ARIGHT                                                    
      ARIGHT= ITEMP                                                    
C ******************************************************************** 
                                                                        
                                                                        
      CALL PORTER(FRQ, EK, ADA, SPEED,                           
     &  ISO, MY, C0, Z0NRM, C1, Z1NRM, ZZ, *9999)

      MODQTY=MAXMOD-MINMOD+1                                            
      CPUEND= ETIME(CPSEC)                                        
      CPEIGV= CPEIGV + (CPUEND - CPUBEG)                                
      RETURN
 9999 RETURN 1
      END