      PROGRAM SPCPGM                                                                                                                
C     PROGRAM SPCPGM (SPT,       SPX,       SPOUT,       INPUT,                 E2                                                  
C    1                                                   OUTPUT,        )       E2                                                  
C    2          TAPE1=SPT, TAPE2=SPX, TAPE3=SPOUT, TAPE5=INPUT,                                                                     
C    3                                             TAPE6=OUTPUT)                                                                    
C     ----------------------------------------------------------                E2                                                  
C                                                                               E2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       E2                                                  
C     JAN 14/93 - E. CHAN  (DECODE LEVELS IN 8-WORD LABEL)                                                                          
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     MAY 13/83 - R.LAPRISE.                                                                                                        
C     DEC 03/80 - J.D.HENDERSON                                                                                                     
C     NOV   /79 - S. LAMBERT                                                                                                        
C                                                                               E2                                                  
CSPCPGM  - MULTIPLY SPECTRAL SETS BY CP*(STATIC STABILITY)              2  1    E1                                                  
C                                                                               E3                                                  
CAUTHOR  - S.LAMBERT, J.D.HENDERSON                                             E3                                                  
C                                                                               E3                                                  
CPURPOSE - MULTIPLIES A FILE OF PRESSURE LEVEL SETS OF SPHERICAL HARMONIC       E3                                                  
C          COEFFICIENTS BY CP*GAMMA(P), WHERE CP IS THE SPECIFIC HEAT OF        E3                                                  
C          DRY AIR AT CONSTANT PRESSURE AND GAMMA(P) IS THE LORENZ STATIC       E3                                                  
C          STABILITY PARAMETER AT PRESSURE LEVEL P.                             E3                                                  
C                                                                               E3                                                  
CINPUT FILES...                                                                 E3                                                  
C                                                                               E3                                                  
C      SPT   = PRESSURE LEVEL SETS OF GLOBAL SPECTRAL                           E3                                                  
C      SPX   = CORRESPONDING FILE TO BE MULTIPLIED.                             E3                                                  
C                                                                               E3                                                  
COUTPUT FILE...                                                                 E3                                                  
C                                                                               E3                                                  
C      SPOUT = SPX*CP*GAMMA(P)                                                  E3                                                  
C---------------------------------------------------------------------------                                                        
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMMON/BLANCK/F(4420)                                                                                                         
C                                                                                                                                   
      LOGICAL OK                                                                                                                    
      DIMENSION TA(100),PRL(100),LEV(100),GAM(100)                                                                                  
      COMMON/ICOM/IBUF(8),IDAT(4420)                                                                                                
      DATA MAXX/4420/, MAXL/100/                                                                                                    
C-----------------------------------------------------------------------                                                            
      NFF=4                                                                                                                         
      CALL JCLPNT(NFF,1,2,3,6)                                                                                                      
      REWIND 1                                                                                                                      
      REWIND 2                                                                                                                      
      REWIND 3                                                                                                                      
      NRECS=0                                                                                                                       
      CP=1004.2E0                                                                                                                   
      R=287.04E0                                                                                                                    
      CALL FILEV(LEV,NLEV,IBUF,1)                                                                                                   
      IF((NLEV.LT.1).OR.(NLEV.GT.MAXL)) CALL       XIT('SPCPGM',-1)                                                                 
      REWIND 1                                                                                                                      
      NLEV1=NLEV-1                                                                                                                  
      CALL LVDCODE(PRL,LEV,NLEV)                                                                                                    
      DO 100 L=1,NLEV                                                                                                               
100   PRL(L)=100.E0*PRL(L)                                                                                                          
C                                                                                                                                   
C     * COMPUTE GLOBAL TEMPERATURE AVERAGE FOR EACH PRESSURE LEVEL                                                                  
C                                                                                                                                   
350   DO 150 L=1,NLEV                                                                                                               
      CALL GETFLD2(1,F,NC4TO8("SPEC"),-1,-1,-1,IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK)THEN                                                                                                               
        IF(NRECS.EQ.0) CALL                        XIT('SPCPGM',-2)                                                                 
        WRITE(6,6020) NRECS                                                                                                         
        CALL                                       XIT('SPCPGM',0)                                                                  
        WRITE(6,6030) IBUF                                                                                                          
      ENDIF                                                                                                                         
      TA(L)=F(1)/SQRT(2.E0)                                                                                                         
150   CONTINUE                                                                                                                      
C                                                                                                                                   
C     * COMPUTE STATIC STABILITY FOR EACH PRESSURE LEVEL                                                                            
C                                                                                                                                   
      DO 200 L=2,NLEV1                                                                                                              
      GAM(L)=1.E0/(TA(L)-(PRL(L)*CP*(TA(L+1)-TA(L-1))/(R*(PRL(L+1)-                                                                 
     1 PRL(L-1)))))                                                                                                                 
200   CONTINUE                                                                                                                      
      GAM(1)=1.E0/(TA(1)-(PRL(1)*CP*(TA(1)-TA(2))/(R*(PRL(1)-PRL(2)))))                                                             
      GAM(NLEV)=1.E0/(TA(NLEV)-(PRL(NLEV)*CP*(TA(NLEV1)-TA(NLEV))/                                                                  
     1 (R*(PRL(NLEV1)-PRL(NLEV)))))                                                                                                 
      DO 250 L=1,NLEV                                                                                                               
      CALL GETFLD2(2,F,NC4TO8("SPEC"),-1,-1,-1,IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('SPCPGM',-3)                                                                 
      IF(NRECS.EQ.0) WRITE(6,6030) IBUF                                                                                             
      NWDS=2*IBUF(5)*IBUF(6)                                                                                                        
C                                                                                                                                   
C     * FORM PRODUCT FILE(SPX)*CP*GAMMA(P)                                                                                          
C                                                                                                                                   
      DO 300 K=1,NWDS                                                                                                               
300   F(K)=CP*GAM(L)*F(K)                                                                                                           
      CALL PUTFLD2(3,F,IBUF,MAXX)                                                                                                   
      IF(NRECS.EQ.0) WRITE(6,6030) IBUF                                                                                             
250   CONTINUE                                                                                                                      
      NRECS=NRECS+1                                                                                                                 
      GO TO 350                                                                                                                     
C-----------------------------------------------------------------------                                                            
6020  FORMAT('0SPCPGM READ',I6,' MULTI-LEVEL SETS')                                                                                 
6030  FORMAT(1X,A4,I10,2X,A4,I10,4I6)                                                                                               
      END                                                                                                                           
