      PROGRAM SPSLOPE                                                                                                               
C     PROGRAM SPSLOPE (IN,       INPUT,       OUTPUT,                   )       A2                                                  
C    1           TAPE1=IN, TAPE5=INPUT, TAPE6=OUTPUT)                                                                               
C     -----------------------------------------------                           A2                                                  
C                                                                               A2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       A2                                                  
C     FEB 15/94 - F.MAJAESS (REVISE FOR TRUNCATIONS > 99)                                                                           
C     JAN 29/92 - E. CHAN   (CONVERT HOLLERITH LITERALS TO ASCII)                                                                   
C     AUG 13/90 - F.MAJAESS (MODIFY THE CALL TO "SPECTRA")                                                                          
C     NOV 24/83 - B.DUGAS.                                                                                                          
C     DEC 01/80 - J.D.HENDERSON                                                                                                     
C     JUL 18/79 - TED SHEPHERD.                                                                                                     
C                                                                               A2                                                  
CSPSLOPE - COMPUTES AND PRINTS SPECTRAL M OR N LOGARITHMIC SLOPE        1  0 C GA1                                                  
C                                                                               A3                                                  
CAUTHOR  - T.SHEPHERD                                                           A3                                                  
C                                                                               A3                                                  
CPURPOSE - CALCULATES AND PRINTS AN ARRAY OF LOGARITHMIC SLOPES OF A            A3                                                  
C          SPECTRAL FIELDS  (ASSUMED REAL) IN EITHER M OR N-SPACE,              A3                                                  
C          BETWEEN INITIAL (KI) AND FINAL (KT) WAVENUMBER INDICES.              A3                                                  
C                                                                               A3                                                  
CINPUT FILE...                                                                  A3                                                  
C                                                                               A3                                                  
C      IN = GLOBAL SPECTRAL FIELDS.                                             A3                                                  
C                                                                                                                                   
CINPUT PARAMETERS...                                                                                                                
C                                                                               A5                                                  
C      SPECTYP          = M OR N TO DETERMINE DIRECTION                         A5                                                  
C      WEIGHT           = 'W', THEN THE QUANTITIES X(N) ARE WEIGHTED TO MAKE    A5                                                  
C                              THEM EQUIVALENT TO A TRIANGULAR TRUNCATION.      A5                                                  
C                         OTHERWISE, WEIGHTING IS SKIPPED.                      A5                                                  
C                         NOTE - THIS IS USED ONLY FOR A RHOMBOIDAL TRUNCATION, A5                                                  
C                                AND AFFECTS ALL N GREATER THAN LM.             A5                                                  
C      LABEL            = 80 CHARACTERS LABEL.                                  A5                                                  
C      NI               = NUMBER OF PAIRS OF WAVENUMBER INTERVALS REQUIRED.     A5                                                  
C      KI,KT            = PAIRS OF WAVENUMBER LIMITS. (UP TO SEVEN PAIRS)       A5                                                  
C      NSTEP,NAM ,LEVEL = RECORD LABEL ID FOR FIELDS TO BE SELECTED.            A5                                                  
C                                                                               A5                                                  
CEXAMPLE OF INPUT CARDS...                                                      A5                                                  
C                                                                               A5                                                  
C*SPSLOPE     N                                                                 A5                                                  
C* JANUARY 1980 KE ECMWF/WMO                                                    A5                                                  
C*  1   10   20                                                                 A5                                                  
C*                31    K    1                                                  A5                                                  
C----------------------------------------------------------------------------                                                       
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMMON/BLANCK/F(4420),G(4420)                                                                                                 
C                                                                                                                                   
      LOGICAL OK                                                                                                                    
      INTEGER LABEL(8)                                                                                                              
      INTEGER LSR(2,66)                                                                                                             
      COMPLEX SUM(130)                                                                                                              
      REAL SLP(7)                                                                                                                   
      INTEGER KI(7),KT(7)                                                                                                           
      CHARACTER*1 SPECTYP,WEIGHT                                                                                                    
C                                                                                                                                   
      COMMON/ICOM/IBUF(8),IDAT(4420)                                                                                                
      DATA MAXX/4420/                                                                                                               
C-----------------------------------------------------------------------                                                            
      NFF=3                                                                                                                         
      CALL JCLPNT(NFF,1,5,6)                                                                                                        
      REWIND 1                                                                                                                      
C                                                                                                                                   
C     * READ SPECTRUM TYPE ('M' OR 'N') AND LABEL.                                                                                  
C                                                                                                                                   
      READ(5,5005,END=902) SPECTYP,WEIGHT                                       A4                                                  
      IF(SPECTYP.EQ.'M')THEN                                                                                                        
        KD=2                                                                                                                        
      ELSE                                                                                                                          
        KD=1                                                                                                                        
      ENDIF                                                                                                                         
      READ(5,5060,END=903) LABEL                                                A4                                                  
C                                                                                                                                   
C     * READ INITIAL (KI) AND TERMINAL (KT) INDICES.                                                                                
C     *   MAXIMUM OF SEVEN SETS.                                                                                                    
C                                                                                                                                   
      READ(5,5010,END=904) NI,(KI(I),KT(I),I=1,7)                               A4                                                  
      WRITE(6,6010)SPECTYP,WEIGHT,(KI(I),KT(I),I=1,NI)                                                                              
C                                                                                                                                   
C     * READ NEXT RECORD FROM INPUT.                                                                                                
C                                                                                                                                   
  100 READ(5,5015,END=900) NSTEP,NAM ,LEVEL                                     A4                                                  
      NAME=NAM                                                                                                                      
      IF(NAM.EQ.NC4TO8(" ALL")) NAME=NC4TO8("NEXT")                                                                                 
700   CALL GETFLD2(1,F,NC4TO8("SPEC"),NSTEP,NAME,LEVEL,IBUF,MAXX,OK)                                                                
      IF(.NOT.OK) THEN                                                                                                              
        IF(NAM.EQ.NC4TO8(" ALL")) THEN                                                                                              
          WRITE(6,6060) LABEL                                                                                                       
          CALL                                     XIT('SPSLOPE',1)                                                                 
        ENDIF                                                                                                                       
        WRITE(6,6020) NSTEP,NAME,LEVEL                                                                                              
        CALL                                       XIT('SPSLOPE',-1)                                                                
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * CHECK TO SEE WHETHER LABELS ARE OLD OR NEW.                                                                                 
C                                                                                                                                   
      LRLMT=IBUF(7)                                                                                                                 
      IF(LRLMT.LT.100) CALL FXLRLMT (LRLMT,IBUF(5),IBUF(6),0)                                                                       
      CALL DIMGT(LSR,LA,LR,LM,KTR,LRLMT)                                                                                            
C                                                                                                                                   
      DO 115 I=1,LA                                                                                                                 
      G(I)=F(I)                                                                                                                     
  115 G(I+LA)=F(I+LA)                                                                                                               
C                                                                                                                                   
C     * SUM OVER THE APPROPRIATE INDEX,CALCULATE SLOPES, AND PRINT.                                                                 
C     * IF KD=1 THEN IT IS IN N-SPACE AND THE SUMS MAY BE WEIGHTED.                                                                 
C                                                                                                                                   
      CALL SPECTRA(G,LM,LR,KTR,LA,LSR,SUM,KD)                                                                                       
C                                                                                                                                   
      IF(KD.EQ.2) GO TO 150                                                                                                         
      IF(KTR.EQ.0) NMAX=LR+LM-2                                                                                                     
      IF(KTR.EQ.2) NMAX=LR-1                                                                                                        
      IF(WEIGHT.NE.'W'.OR.KTR.NE.0) GO TO 180                                                                                       
      NMAX1=NMAX+1                                                                                                                  
      DO 120 N=LM,NMAX1                                                                                                             
  120 SUM(N)=SUM(N)*FLOAT(N)/FLOAT(LR-N+1)                                                                                          
      GO TO 180                                                                                                                     
  150 NMAX=LM-1                                                                                                                     
C                                                                                                                                   
  180 DO 300 I=1,NI                                                                                                                 
      NK=KT(I)-KI(I)+1                                                                                                              
      IF(NK.LE.1.OR.KT(I).GT.NMAX)THEN                                                                                              
        WRITE(6,6030) KI(I),KT(I)                                                                                                   
        CALL                                       XIT('SPSLOPE',-2)                                                                
      ENDIF                                                                                                                         
      A=0                                                                                                                           
      B=0                                                                                                                           
      C=0                                                                                                                           
      D=0                                                                                                                           
      INIT=KI(I)                                                                                                                    
      LAST=KT(I)                                                                                                                    
C                                                                                                                                   
      DO 200 K=INIT,LAST                                                                                                            
      A=A+LOG(FLOAT(K))*LOG(ABS(SUM(K+1)))                                                                                          
      B=B+LOG(FLOAT(K))                                                                                                             
      C=C+LOG(ABS(SUM(K+1)))                                                                                                        
  200 D=D+(LOG(FLOAT(K)))**2                                                                                                        
  300 SLP(I)=(FLOAT(NK)*A-B*C)/(FLOAT(NK)*D-B**2)                                                                                   
C                                                                                                                                   
      WRITE(6,6040) NSTEP,NAME,LEVEL,(SLP(I),I=1,NI)                                                                                
      IF(NAM.EQ.NC4TO8(" ALL")) GO TO 700                                                                                           
      GO TO 100                                                                                                                     
C                                                                                                                                   
C     * E.O.F. ON INPUT.                                                                                                            
C                                                                                                                                   
  900 WRITE(6,6060)LABEL                                                                                                            
      CALL                                         XIT('SPSLOPE',0)                                                                 
  902 CALL                                         XIT('SPSLOPE',-3)                                                                
  903 CALL                                         XIT('SPSLOPE',-4)                                                                
  904 CALL                                         XIT('SPSLOPE',-5)                                                                
C-----------------------------------------------------------------------                                                            
 5005 FORMAT(10X,4X,A1,4X,A1)                                                   A4                                                  
 5010 FORMAT(15I5)                                                              A4                                                  
 5015 FORMAT(10X,I10,1X,A4,I5)                                                  A4                                                  
 5060 FORMAT(10A8)                                                              A4                                                  
 6010 FORMAT('0  STEP  NAME LEVEL ',2A1,'  (KI,KT)',7(3X,I2,4X,I2,4X))                                                              
 6020 FORMAT('0..EOF LOOKING FOR',I10,2X,A4,I5)                                                                                     
 6030 FORMAT('0...PROBLEM WITH INDEX LIMITS',I5,I5)                                                                                 
 6040 FORMAT(' ',I6,2X,A4,I6,13X,7(1PE13.6,2X))                                                                                     
 6060 FORMAT('0',48X,10A8)                                                                                                          
      END                                                                                                                           
