      PROGRAM SPRESOL                                                                                                               
C     PROGRAM SPRESOL (SPIN,       SPOUT,       INPUT,       OUTPUT,    )       E2                                                  
C    1           TAPE1=SPIN, TAPE2=SPOUT, TAPE5=INPUT, TAPE6=OUTPUT)                                                                
C     --------------------------------------------------------------            E2                                                  
C                                                                               E2                                                  
C     JUL 06/04 - F.MAJAESS (CORRECT THE COMMENTS ABOUT LR AND LM)              E2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)                                                           
C     FEB 15/94 - F.MAJAESS (REVISE FOR TRUNCATIONS > 99)                                                                           
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     MAY 14/83 - R.LAPRISE.                                                                                                        
C     DEC 01/80 - J.D.HENDERSON                                                                                                     
C     NOV   /79 - S. LAMBERT                                                                                                        
C                                                                               E2                                                  
CSPRESOL - EXTRACTS LOWER RESOLUTION SUB-SET FROM SPECTRAL FILE         1  1 C GE1                                                  
C                                                                               E3                                                  
CAUTHOR  - S.LAMBERT                                                            E3                                                  
C                                                                               E3                                                  
CPURPOSE - RETURNS IN SPOUT FILE A LOWER SPECTRAL RESOLUTION SUB-SET OF         E3                                                  
C          THE INPUT GLOBAL SPHERICAL HARMONIC COEFFICIENTS IN SPIN FILE.       E3                                                  
C                                                                               E3                                                  
CINPUT FILE...                                                                  E3                                                  
C                                                                               E3                                                  
C      SPIN  = GLOBAL SPECTRAL FIELDS                                           E3                                                  
C                                                                               E3                                                  
COUTPUT FILE...                                                                 E3                                                  
C                                                                               E3                                                  
C      SPOUT = GLOBAL SPECTRAL FIELDS WITH LOWER SPECTRAL RESOLUTION            E3                                                  
C                                                                                                                                   
CINPUT PARAMETER...                                                                                                                 
C                                                                               E5                                                  
C      LRLMT = ONE NUMBER CONTAINING THE REQUIRED RESOLUTION.                   E5                                                  
C              THIS NUMBER CONTAINS FIVE DIGITS...                              E5                                                  
C              LR = FIRST  TWO DIGITS = N TRUNCATION                            E5                                                  
C              LM = SECOND TWO DIGITS = M TRUNCATION                            E5                                                  
C              T  = LAST DIGIT        = TYPE OF TRUNCATION;                     E5                                                  
C                                       (0=GLOBAL,2=TRIANGULAR).                E5                                                  
C                                                                               E5                                                  
CEXAMPLE OF INPUT CARD...                                                       E5                                                  
C                                                                               E5                                                  
C* SPRESOL     15152                                                            E5                                                  
C                                                                               E5                                                  
C     THIS EXTRACTS SPECTRAL FIELDS WITH 14 WAVES IN THE M AND N                E5                                                  
C     DIRECTIONS AND WITH TRIANGULAR TRUNCATION.                                E5                                                  
C------------------------------------------------------------------------------                                                     
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMPLEX F                                                                                                                     
      COMMON/BLANCK/F(2210)                                                                                                         
C                                                                                                                                   
      LOGICAL OK                                                                                                                    
      DIMENSION LSRI(2,66),LSRO(2,66)                                                                                               
      COMMON/ICOM/IBUF(8),IDAT(4420)                                                                                                
      DATA MAXX/4420/                                                                                                               
C-----------------------------------------------------------------------                                                            
C                                                                                                                                   
      NFF=4                                                                                                                         
      CALL JCLPNT(NFF,1,2,5,6)                                                                                                      
      READ(5,5000,END=902) LRLMT                                                E4                                                  
      CALL DIMGT(LSRO,LAO,LRO,LMO,KTRO,LRLMT)                                                                                       
      NRECS=0                                                                                                                       
      REWIND 1                                                                                                                      
      REWIND 2                                                                                                                      
  100 CALL GETFLD2(1,F,NC4TO8("SPEC"),-1,-1,-1,IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK)THEN                                                                                                               
        IF(NRECS.EQ.0) CALL                        XIT('SPRESOL',-1)                                                                
        WRITE(6,6020) NRECS                                                                                                         
        CALL                                       XIT('SPRESOL',0)                                                                 
      ENDIF                                                                                                                         
      IF(NRECS.EQ.0) CALL PRTLAB (IBUF)                                                                                             
      CALL DIMGT(LSRI,LAI,LRI,LMI,KTRI,IBUF(7))                                                                                     
      IF(LMO.GT.LMI)THEN                                                                                                            
        WRITE(6,6040) LMI,LMO                                                                                                       
        CALL                                       XIT('SPRESOL',-101)                                                              
      ENDIF                                                                                                                         
      KK=0                                                                                                                          
      DO 200 M=1,LMO                                                                                                                
200   IF((LSRO(1,M+1)-LSRO(1,M)).GT.(LSRI(1,M+1)-LSRI(1,M))) KK=1                                                                   
      IF(KK.NE.0)THEN                                                                                                               
        WRITE(6,6050)                                                                                                               
        CALL                                       XIT('SPRESOL',-102)                                                              
      ENDIF                                                                                                                         
      DO 300 M=1,LMO                                                                                                                
      N=LSRO(1,M+1)-LSRO(1,M)                                                                                                       
      DO 300 J=1,N                                                                                                                  
300   F(LSRO(1,M)-1+J)=F(LSRI(1,M)-1+J)                                                                                             
      IBUF(5)=LAO                                                                                                                   
      IBUF(7)=LRLMT                                                                                                                 
      CALL PUTFLD2(2,F,IBUF,MAXX)                                                                                                   
      IF(NRECS.EQ.0) CALL PRTLAB (IBUF)                                                                                             
      NRECS=NRECS+1                                                                                                                 
      GO TO 100                                                                                                                     
C                                                                                                                                   
C     * E.O.F. ON INPUT.                                                                                                            
C                                                                                                                                   
  902 CALL                                         XIT('SPRESOL',-2)                                                                
C-----------------------------------------------------------------------                                                            
 5000 FORMAT(10X,I10)                                                           E4                                                  
 6020 FORMAT('0SPRESOL CONVERTED ',I5,' RECORDS')                                                                                   
 6040 FORMAT('0INSUFFICIENT RESOLUTION IN INPUT FILE INPUT=',I3,                                                                    
     1 ' OUTPUT=',I3)                                                                                                               
 6050 FORMAT('0INSUFFICIENT RESOLUTION IN INPUT FILE')                                                                              
      END                                                                                                                           
