      PROGRAM SPKECOR                                                                                                               
C     PROGRAM SPKECOR (SPVORT,        SPDIV,        SPU,         SPV,           E2                                                  
C    1                                SPCOR,        INPUT,       OUTPUT,)       E2                                                  
C    2          TAPE11=SPVORT, TAPE12=SPDIV, TAPE13=SPU,  TAPE14=SPV,                                                               
C    3                         TAPE15=SPCOR, TAPE5 =INPUT, TAPE6=OUTPUT)                                                            
C     ------------------------------------------------------------------        E2                                                  
C                                                                               E2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       E2                                                  
C     FEB 15/94 - F.MAJAESS (REVISE FOR TRUNCATIONS > 99)                                                                           
C     JUL 13/92 - E. CHAN  (DIMENSION EPSI AS REAL*8)                                                                               
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     MAY 13/83 - R.LAPRISE.                                                                                                        
C     FEB   /80 - S. LAMBERT                                                                                                        
C                                                                               E2                                                  
CSPKECOR - COMPUTES SPECTRAL CORIOLIS TERMS IN K.E. BUDGET              4  1   GE1                                                  
C                                                                               E3                                                  
CAUTHOR  - S.LAMBERT                                                            E3                                                  
C                                                                               E3                                                  
CPURPOSE - COMPUTES THE CONTRIBUTIONS FROM THE CORIOLIS TERMS IN THE            E3                                                  
C          KINETIC ENERGY BUDGET.                                               E3                                                  
C                                                                               E3                                                  
CINPUT FILES...                                                                 E3                                                  
C                                                                               E3                                                  
C      SPVORT = GLOBAL SPECTRAL VORTICITY.                                      E3                                                  
C      SPDIV  = GLOBAL SPECTRAL DIVERGENCE                                      E3                                                  
C      SPU    = GLOBAL SPECTRAL MODEL WIND COMPONENT U.                         E3                                                  
C      SPV    = GLOBAL SPECTRAL MODEL WIND COMPONENT V.                         E3                                                  
C                                                                               E3                                                  
COUTPUT FILE...                                                                 E3                                                  
C                                                                               E3                                                  
C      SPCOR = SPECTRAL CORIOLIS CONTRIBUTIONS.                                 E3                                                  
C-----------------------------------------------------------------------------                                                      
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMPLEX Q,D,U,V,F                                                                                                             
      COMMON/BLANCK/Q(2145),D(2145),U(2210),V(2210),F(2145)                                                                         
      LOGICAL OK                                                                                                                    
      INTEGER LSR(2,66)                                                                                                             
      REAL*8 EPSI(2275)                                                                                                             
      COMMON/ICOM/IBUF(8),IDAT(4420)                                                                                                
      COMMON/JCOM/JBUF(8),JDAT(4420)                                                                                                
      COMMON/KCOM/KBUF(8),KDAT(4420)                                                                                                
      COMMON/LCOM/LBUF(8),LDAT(4420)                                                                                                
      DATA MAXX/4420/                                                                                                               
C-----------------------------------------------------------------------                                                            
      NFF=6                                                                                                                         
      CALL JCLPNT(NFF,11,12,13,14,15,6)                                                                                             
      DO 110 N=11,15                                                                                                                
110   REWIND N                                                                                                                      
      NR=0                                                                                                                          
160   CALL GETFLD2(11,Q,NC4TO8("SPEC"),-1,NC4TO8("VORT"),-1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6010) NR                                                                                                            
        IF(NR.EQ.0) CALL                           XIT('SPKECOR',-1)                                                                
        CALL                                       XIT('SPKECOR',0)                                                                 
      ENDIF                                                                                                                         
      NST=IBUF(2)                                                                                                                   
      LEVEL=IBUF(4)                                                                                                                 
      CALL GETFLD2(12,D,NC4TO8("SPEC"),NST,NC4TO8(" DIV"),LEVEL,                                                                    
     +                                             JBUF,MAXX,OK)                                                                    
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6010) NR                                                                                                            
        CALL                                       XIT('SPKECOR',-2)                                                                
      ENDIF                                                                                                                         
      CALL CMPLBL(0,IBUF,0,JBUF,OK)                                                                                                 
      IF(.NOT.OK)THEN                                                                                                               
        CALL PRTLAB (IBUF)                                                                                                          
        CALL PRTLAB (JBUF)                                                                                                          
        CALL                                       XIT('SPKECOR',-200)                                                              
      ENDIF                                                                                                                         
      CALL GETFLD2(13,U,NC4TO8("SPEC"),NST,NC4TO8("   U"),LEVEL,                                                                    
     +                                             KBUF,MAXX,OK)                                                                    
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6010) NR                                                                                                            
        CALL                                       XIT('SPKECOR',-3)                                                                
      ENDIF                                                                                                                         
      CALL GETFLD2(14,V,NC4TO8("SPEC"),NST,NC4TO8("   V"),LEVEL,                                                                    
     +                                             LBUF,MAXX,OK)                                                                    
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6010) NR                                                                                                            
        CALL                                       XIT('SPKECOR',-4)                                                                
      ENDIF                                                                                                                         
      CALL CMPLBL(0,KBUF,0,LBUF,OK)                                                                                                 
      IF(.NOT.OK)THEN                                                                                                               
        CALL PRTLAB (IBUF)                                                                                                          
        CALL PRTLAB (LBUF)                                                                                                          
        CALL                                       XIT('SPKECOR',-400)                                                              
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * FIRST TIME ONLY, CALCULATE CONSTANTS.                                                                                       
C                                                                                                                                   
      IF(NR.GT.0) GO TO 210                                                                                                         
      CALL PRTLAB (IBUF)                                                                                                            
      CALL PRTLAB (JBUF)                                                                                                            
      CALL PRTLAB (KBUF)                                                                                                            
      CALL PRTLAB (LBUF)                                                                                                            
      LRLMT=IBUF(7)                                                                                                                 
      IF(LRLMT.LT.100) CALL FXLRLMT (LRLMT,IBUF(5),IBUF(6),0)                                                                       
      CALL DIMGT(LSR,LA,LR,LM,KTR,LRLMT)                                                                                            
      CALL PRLRLMT (LA,LR,LM,KTR,LRLMT)                                                                                             
      CALL EPSCAL(EPSI,LSR,LM)                                                                                                      
C                                                                                                                                   
C     * COMPUTE CORIOLIS TERMS                                                                                                      
C                                                                                                                                   
210   CALL FTERMS(F,U,V,Q,D,EPSI,LSR,LM)                                                                                            
      DO 300 I=1,LR                                                                                                                 
300   F(I)=0.5E0*F(I)                                                                                                               
C                                                                                                                                   
C     * PACK THE FIELD ONTO THE OUTPUT FILE                                                                                         
C                                                                                                                                   
      IBUF(3)=NC4TO8(" COR")                                                                                                        
      CALL PUTFLD2(15,F,IBUF,MAXX)                                                                                                  
      IF(NR.EQ.0) CALL PRTLAB (IBUF)                                                                                                
      NR=NR+1                                                                                                                       
      GO TO 160                                                                                                                     
C-----------------------------------------------------------------------                                                            
6010  FORMAT('0SPKECOR COMPUTED',I6,' RECORDS')                                                                                     
      END                                                                                                                           
