      PROGRAM SPCDNS                                                                                                                
C     PROGRAM SPCDNS (ALPHA,       BETA,       ANS,       OUTPUT,       )       E2                                                  
C    1          TAPE1=ALPHA, TAPE2=BETA, TAPE3=ANS, TAPE6=OUTPUT)                                                                   
C     -----------------------------------------------------------               E2                                                  
C                                                                               E2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       E2                                                  
C     NOV 20/00 - S.KHARIN (MAKE BETA OPTIONAL)                                                                                     
C     AUG 05/94 - F.MAJAESS (REVISE FOR TRUNCATIONS > 99)                                                                           
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     MAY 13/83 - R.LAPRISE.                                                                                                        
C     DEC 01/80 - J.D.HENDERSON                                                                                                     
C     NOV   /79 - S. LAMBERT                                                                                                        
C                                                                               E2                                                  
CSPCDNS  - CONTRIBUTION OF SPH. HAR. COEF. TO GLOBAL MEAN OF PRODUCT    2  1   GE1                                                  
C                                                                               E3                                                  
CAUTHOR  - S.LAMBERT, J.D.HENDERSON                                             E3                                                  
C                                                                               E3                                                  
CPURPOSE - COMPUTES THE CONTRIBUTION OF EACH PAIR OF SPHERICAL                  E3                                                  
C          HARMONIC COEFFICIENTS TO THE GLOBAL AVERAGE OF THE PRODUCT           E3                                                  
C          OF THE TWO INPUT FILES.                                              E3                                                  
C                                                                               E3                                                  
CINPUT FILES...                                                                 E3                                                  
C                                                                               E3                                                  
C      ALPHA = FIRST SPECTRAL FILE.                                             E3                                                  
C      BETA  = (OPTIONAL) SECOND SPECTRAL FILE.                                 E3                                                  
C              IF NOT PRESENT, OR '_' IS SPECIFIED, ASSUME BETA=ALPHA.          E3                                                  
C                                                                               E3                                                  
COUTPUT FILE...                                                                 E3                                                  
C                                                                               E3                                                  
C      ANS   = CONTRIBUTIONS TO THE GLOBAL AVERAGE                              E3                                                  
C----------------------------------------------------------------------------                                                       
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMPLEX F,G                                                                                                                   
C                                                                                                                                   
      LOGICAL OK,CV                                                                                                                 
      COMMON/BLANCK/F(2210),G(2210)                                                                                                 
      COMMON/ICOM/IBUF(8),IDAT(4420)                                                                                                
      COMMON/NCOM/NBUF(8),NDAT(4420)                                                                                                
                                                                                                                                    
C     * IUA/IUST  - ARRAY KEEPING TRACK OF UNITS ASSIGNED/STATUS.                                                                   
      INTEGER IUA(100),IUST(100)                                                                                                    
      COMMON /JCLPNTU/ IUA,IUST                                                                                                     
                                                                                                                                    
      DATA MAXX/4420/                                                                                                               
C-----------------------------------------------------------------------                                                            
      NFF=4                                                                                                                         
      CALL JCLPNT(NFF,1,2,3,6)                                                                                                      
      IF(NFF.LT.3) CALL                            XIT('SPCDNS',-1)                                                                 
                                                                                                                                    
      REWIND 1                                                                                                                      
      NOUT=3                                                                                                                        
      IF (NFF.EQ.3) THEN                                                                                                            
         CV=.FALSE.                                                                                                                 
         IF (IUST(2).EQ.1) NOUT=2                                                                                                   
      ELSE                                                                                                                          
         CV=.TRUE.                                                                                                                  
         REWIND 2                                                                                                                   
      ENDIF                                                                                                                         
      REWIND NOUT                                                                                                                   
                                                                                                                                    
      NRECS=0                                                                                                                       
   50 CALL GETFLD2(1,F,NC4TO8("SPEC"),-1,-1,-1,IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK)THEN                                                                                                               
        IF(NRECS.EQ.0) CALL                        XIT('SPCDNS',-2)                                                                 
        WRITE(6,6100) NRECS                                                                                                         
        CALL                                       XIT('SPCDNS',0)                                                                  
      ENDIF                                                                                                                         
      IF(NRECS.EQ.0) CALL PRTLAB(IBUF)                                                                                              
      IF (CV) THEN                                                                                                                  
         CALL GETFLD2(2,G,NC4TO8("SPEC"),-1,-1,-1,NBUF,MAXX,OK)                                                                     
         IF(.NOT.OK) CALL                          XIT('SPCDNS',-3)                                                                 
         IF(NRECS.EQ.0) CALL PRTLAB(NBUF)                                                                                           
         IF(NBUF(5).NE.IBUF(5)) CALL               XIT('SPCDNS',-100)                                                               
      ENDIF                                                                                                                         
      LA=IBUF(5)                                                                                                                    
      IF(IBUF(7).LE.99999) THEN                                                                                                     
       LR=(IBUF(7)/1000)                                                                                                            
      ELSE                                                                                                                          
       LR=(IBUF(7)/10000)                                                                                                           
      ENDIF                                                                                                                         
      IF (CV) THEN                                                                                                                  
         DO 100 IG=1,LA                                                                                                             
            A=REAL(F(IG))*REAL(G(IG))+ IMAG(F(IG))* IMAG(G(IG))                                                                     
            G(IG)=CMPLX(A,0.E0)                                                                                                     
 100     CONTINUE                                                                                                                   
      ELSE                                                                                                                          
         DO 110 IG=1,LA                                                                                                             
            A=REAL(F(IG))*REAL(F(IG))+ IMAG(F(IG))* IMAG(F(IG))                                                                     
            G(IG)=CMPLX(A,0.E0)                                                                                                     
 110     CONTINUE                                                                                                                   
      ENDIF                                                                                                                         
      DO 150 K=1,LR                                                                                                                 
150   G(K)=G(K)*0.5E0                                                                                                               
      CALL PUTFLD2(NOUT,G,IBUF,MAXX)                                                                                                
      IF(NRECS.EQ.0) CALL PRTLAB(NBUF)                                                                                              
      NRECS=NRECS+1                                                                                                                 
      GO TO 50                                                                                                                      
C----------------------------------------------------------------------                                                             
6100  FORMAT('0SPCDNS PROCESSED ',I4,' RECORDS')                                                                                    
      END                                                                                                                           
