      PROGRAM GLOBAVG                                                                                                               
C     PROGRAM GLOBAVG (CHAMP,       SINT,       SINT1,       GMASK,             C2                                                  
C    1                                                       OUTPUT,    )       C2                                                  
C    2           TAPE1=CHAMP, TAPE2=SINT, TAPE3=SINT1, TAPE4=GMASK,             C2                                                  
C    3                                                 TAPE6=OUTPUT)            C2                                                  
C     -------------------------------------------------------------             C2                                                  
C                                                                               C2                                                  
C     SEP 24/13 - S.KHARIN  (ADD OPTIONAL MASK INPUT FILE)                      C2                                                  
C     NOV 23/10 - S.KHARIN  (MINOR REVISION IN SUPPORT OF 1X1 GRID SIZE)                                                            
C     FEB 16/10 - F.MAJAESS (ENSURE "ILAT" IS WITHIN SINGLE ARRAY DIMENSION)                                                        
C     NOV 23/09 - S.KHARIN  (ADD OPTIONAL OUTPUT FILE WITH A SINGLE AVG VALUE)                                                      
C     MAR 18/09 - S.KHARIN  (PUT GLOBAL AVERAGE TO ALL GRIDPOINTS OF AVG)                                                           
C     DEC 12/06 - F.MAJAESS (BYPASS WRITING TO STANDARD OUTPUT IF AN OUTPUT                                                         
C                            FILE IS SPECIFIED)                                                                                     
C     SEP 18/06 - F.MAJAESS (IMPROVE SPECIAL VALUE HANDLING)                                                                        
C     FEB 18/05 - S.KHARIN (CHECK FOR ILAT=EVEN NUMBER)                                                                             
C     NOV 02/04 - S.KHARIN (PRINT AVERAGES EXCLUDING SPECIAL VALUES.                                                                
C                           PRINT DIMENSIONS OF THE FIELDS.)                                                                        
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)                                                           
C     MAR 05/02 - F.MAJAESS (REVISED FOR "CHAR" KIND RECORDS)                                                                       
C     JAN 17/01 - F. MAJAESS (RESET "F" ARRAY VALUES ONLY IF TO BE WRIITEN OUT)                                                     
C     JUL 13/92 - E. CHAN    (DIMENSION SELECTED VARIABLES AS REAL*8)                                                               
C     JAN 29/92 - E. CHAN    (CONVERT HOLLERITH LITERALS TO ASCII)                                                                  
C     MAY 15/90 - F. MAJAESS (REFORMAT OUTPUT WHEN TAPE6 NOT ASSIGNED TO                                                            
C                                                        THE STANDARD OUTPUT)                                                       
C     APR 14/88 - F. MAJAESS (ENFORCE VECTORIZATION OF THE DO LOOP                                                                  
C                             180 BY USING A SCALAR TO ACCUMULATE                                                                   
C                             THE SUM INSTEAD OF A VECTOR ELEMENT)                                                                  
C     NOV 16/87 - F. MAJAESS (ELIMINATE DULICATE WEIGHT CALCULATIONS.                                                               
C                             CONTROL COMPUTED VALUES WRITING TO FILE                                                               
C                             "OUTPUT" VIA "SINT" FILE SPECIFICATION                                                                
C                             ON THE PROGRAM CALL CARD).                                                                            
C     NOV 29/83 - B. DUGAS.                                                                                                         
C                                                                               C2                                                  
CGLOBAVG - CALCULATES SURFACE MEAN OF FIELD                             1  2    C1                                                  
C                                                                               C3                                                  
CAUTHOR  - B.DUGAS                                                              C3                                                  
C                                                                               C3                                                  
CPURPOSE - CALCULATES THE SURFACE MEAN OF VALUES IN CHAMP FILE WHICH            C3                                                  
C          CAN BE OF SPECTRAL OR FOURIER WAVES, ZONAL CROSS-SECTIONS            C3                                                  
C          OR GAUSSIAN GRID(S) TYPE.                                            C3                                                  
C          NOTE - NAMES ARE NOT CHECKED AND "LABL" AND/OR "CHAR" KIND           C3                                                  
C                 RECORDS ARE SIMPLY SKIPPED.                                   C3                                                  
C                                                                               C3                                                  
CINPUT FILE...                                                                  C3                                                  
C                                                                               C3                                                  
C      CHAMP = INPUT FILE OF FIELDS.                                            C3                                                  
C              THE FILE CAN CONTAIN "LABL" AND/OR "CHAR" KIND RECORDS.          C3                                                  
C              THE FIELDS THEMSELVES CAN BE TYPE ZONL, GRID, SPEC OR FOUR.      C3                                                  
C      GMASK = (OPTIONAL) MASK TO BE USED TO COMPUTE SPATIAL MEAN:              C3                                                  
C              SINT=MEAN(CHAMP*GMASK)/MEAN(GMASK). VALID ONLY FOR KIND=GRID.    C3                                                  
C              ONLY THE FIRST RECORD OF GMASK IS USED.                          C3                                                  
C                                                                               C3                                                  
COUTPUT FILE...                                                                 C3                                                  
C                                                                               C3                                                  
C      SINT  = (OPTIONAL) IF SINT IS SPECIFIED THEN                             C3                                                  
C                THE COMPUTED VALUES ARE WRITTEN TO FILE SINT.                  C3                                                  
C                THE TYPE OF FILE SINT IS THE SAME AS THAT FOR THE INPUT FILE   C3                                                  
C                CHAMP. (UNCHANGED IBUF STRUCTURE FOR EACH RECORD).             C3                                                  
C      SINT1 = (OPTIONAL) IF SINT1 IS SPECIFIED THEN                            C3                                                  
C                THE COMPUTED AVG VALUE IS WRITTEN TO FILE SINT1.               C3                                                  
C                THE TYPE OF FILE SINT1 IS 1X1 GRID.                            C3                                                  
C              IF NONE OF SINT OR SINT1 ARE SPECIFIED,                          C3                                                  
C              THE COMPUTED AVG VALUES ARE PRINTED OUT ONLY.                    C3                                                  
C-----------------------------------------------------------------------                                                            
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMMON/JCLPNTR/STDOUT                                                                                                         
      COMMON/F/F(65341),GMASK(65341)                                                                                                
      INTEGER JBUF(8)                                                                                                               
      COMMON/ICOM/IBUF(8),IDAT(65341)                                                                                               
      REAL*8 SL(181),WL(181),CL(181),RADL(181),WOSSL(181)                                                                           
C                                                                                                                                   
C     * IUA/IUST  - ARRAY KEEPING TRACK OF UNITS ASSIGNED/STATUS.                                                                   
C                                                                                                                                   
      INTEGER IUA(100),IUST(100)                                                                                                    
      COMMON /JCLPNTU/ IUA,IUST                                                                                                     
C                                                                                                                                   
      LOGICAL OK,LISTCV,STDOUT,LMASK                                                                                                
      DATA MAXX/65341/,SPVAL/1.E+38/,SPVALT/1.E+32/                                                                                 
      DATA MAXLAT /181/                                                                                                             
C-------------------------------------------------------------------                                                                
                                                                                                                                    
      NF=5                                                                                                                          
      CALL JCLPNT(NF,1,2,3,4,6)                                                                                                     
      REWIND 1                                                                                                                      
      LISTCV=.TRUE.                                                                                                                 
      IF (IUST(2).EQ.1) THEN                                                                                                        
        LISTCV=.FALSE.                                                                                                              
        REWIND 2                                                                                                                    
      ENDIF                                                                                                                         
      IF (IUST(3).EQ.1) THEN                                                                                                        
        LISTCV=.FALSE.                                                                                                              
        REWIND 3                                                                                                                    
      ENDIF                                                                                                                         
      LMASK=.FALSE.                                                                                                                 
      IF (IUST(4).EQ.1) THEN                                                                                                        
        REWIND 4                                                                                                                    
        LMASK=.TRUE.                                                                                                                
      ENDIF                                                                                                                         
C                                                                                                                                   
C     *  READ IN THE FIRST FIELD IN CHAMP                                                                                           
C                                                                                                                                   
      NFL = 0                                                                                                                       
      ILATWL=-1.E-99                                                                                                                
  100 CALL GETFLD2 (1,F,-1,-1,-1,-1,IBUF,MAXX,OK)                                                                                   
      IF (.NOT.OK)THEN                                                                                                              
        IF (STDOUT) WRITE(6,6010) NFL                                                                                               
        IF (NFL.EQ.0)THEN                                                                                                           
          CALL                                     XIT('GLOBAVG',-1)                                                                
        ELSE                                                                                                                        
          IF (STDOUT) THEN                                                                                                          
            CALL                                   XIT('GLOBAVG',0)                                                                 
          ELSE                                                                                                                      
            STOP                                                                                                                    
          ENDIF                                                                                                                     
        ENDIF                                                                                                                       
      ENDIF                                                                                                                         
C                                                                                                                                   
C       * CHECK RECORD TYPE                                                                                                         
C                                                                                                                                   
      IF (IBUF(1).EQ.NC4TO8("SPEC"))   GO TO 110                                                                                    
      IF (IBUF(1).EQ.NC4TO8("ZONL"))   GO TO 120                                                                                    
      IF (IBUF(1).EQ.NC4TO8("FOUR"))   GO TO 140                                                                                    
      IF (IBUF(1).EQ.NC4TO8("GRID"))   GO TO 160                                                                                    
      IF (IBUF(1).EQ.NC4TO8("LABL").OR.                                                                                             
     +    IBUF(1).EQ.NC4TO8("CHAR"))   GO TO 100                                                                                    
      CALL                                         XIT('GLOBAVG',-2)                                                                
C                                                                                                                                   
C     *  SPECTRAL CASE                                                                                                              
C                                                                                                                                   
  110 D = F(1) / SQRT(2.E0)                                                                                                         
      IF (.NOT.LISTCV) THEN                                                                                                         
        LA2 = IBUF(5)*2                                                                                                             
        DO 115 I=2,LA2                                                                                                              
          F(I) = 0.E0                                                                                                               
  115   CONTINUE                                                                                                                    
        IF (IUST(2).EQ.1) THEN                                                                                                      
          CALL PUTFLD2(2,F,IBUF,MAXX)                                                                                               
        ENDIF                                                                                                                       
        IF (IUST(3).EQ.1) THEN                                                                                                      
C                                                                                                                                   
C         * SAVE SCALAR                                                                                                             
C                                                                                                                                   
          IBUF(1)=NC4TO8("GRID")                                                                                                    
          IBUF(5)=1                                                                                                                 
          IBUF(6)=1                                                                                                                 
          IBUF(8)=1                                                                                                                 
          CALL PUTFLD2(3,D,IBUF,MAXX)                                                                                               
        ENDIF                                                                                                                       
      ELSE                                                                                                                          
        WRITE(6,6020) (IBUF(N),N=1,6),D                                                                                             
      ENDIF                                                                                                                         
      NFL = NFL + 1                                                                                                                 
      GO TO 100                                                                                                                     
C                                                                                                                                   
C     *  ZONAL CASE TRANSFORMATION                                                                                                  
C                                                                                                                                   
  120 ILG = 1                                                                                                                       
      ILON = 1                                                                                                                      
      ILAT = IBUF(5)                                                                                                                
      GO TO 170                                                                                                                     
C                                                                                                                                   
C     *  FOURIER CASE TRANFORMATION                                                                                                 
C                                                                                                                                   
  140 ILG = IBUF(5)*2                                                                                                               
      ILON = 1                                                                                                                      
      ILAT = IBUF(6)                                                                                                                
      GO TO 170                                                                                                                     
C                                                                                                                                   
C     * DEF OF GRID CASE PARAMETERS                                                                                                 
C                                                                                                                                   
  160 ILG = IBUF(5)                                                                                                                 
      ILON = ILG-1                                                                                                                  
      ILAT = IBUF(6)                                                                                                                
C                                                                                                                                   
C     * READ IN MASK, IF SPECIFIED (ONLY THE FIRST RECORD IS READ)                                                                  
C                                                                                                                                   
      IF (LMASK.AND.NFL.EQ.0) THEN                                                                                                  
C                                                                                                                                   
C       * PRESERVE IBUF(1-8)                                                                                                        
C                                                                                                                                   
        DO I=1,8                                                                                                                    
          JBUF(I)=IBUF(I)                                                                                                           
        ENDDO                                                                                                                       
        CALL GETFLD2 (4,GMASK,NC4TO8("GRID"),-1,-1,-1,IBUF,MAXX,OK)                                                                 
C                                                                                                                                   
C       * CHECK DIMENSIONS                                                                                                          
C                                                                                                                                   
        IF(IBUF(5).NE.ILG.OR.IBUF(6).NE.ILAT) CALL XIT('GLOBAVG',-3)                                                                
C                                                                                                                                   
C       * RESTORE IBUF(1-8)                                                                                                         
C                                                                                                                                   
        DO I=1,8                                                                                                                    
          IBUF(I)=JBUF(I)                                                                                                           
        ENDDO                                                                                                                       
      ENDIF                                                                                                                         
                                                                                                                                    
      IF(ILAT.EQ.1.AND.ILG.EQ.1)THEN                                                                                                
        D=F(1)                                                                                                                      
        GOTO 175                                                                                                                    
      ENDIF                                                                                                                         
C                                                                                                                                   
C     *  COMPUTATIONS COMMON TO GRID, FOUR AND ZONL CASES                                                                           
C                                                                                                                                   
  170 IF (ILAT.GT.MAXLAT)  CALL                    XIT('GLOBAVG',-4)                                                                
      ILATH = ILAT / 2                                                                                                              
      IF (2*ILATH.NE.ILAT) CALL                    XIT('GLOBAVG',-5)                                                                
      IF(ILATWL.NE.ILATH)THEN                                                                                                       
        ILATWL=ILATH                                                                                                                
        CALL GAUSSG (ILATH,SL,WL,CL,RADL,WOSSL)                                                                                     
        CALL TRIGL (ILATH,SL,WL,CL,RADL,WOSSL)                                                                                      
      ENDIF                                                                                                                         
C                                                                                                                                   
      SFW = 0.E0                                                                                                                    
      SW  = 0.E0                                                                                                                    
      NSP = 0                                                                                                                       
      DO J=1,ILAT                                                                                                                   
        DO I=1,ILON                                                                                                                 
          IJ = (J - 1) * ILG + I                                                                                                    
          IF(ABS(F(IJ)-SPVAL).GT.SPVALT) THEN                                                                                       
            IF(LMASK)THEN                                                                                                           
              SFW = SFW + WL(J) * GMASK(IJ) * F(IJ)                                                                                 
              SW  = SW  + WL(J) * GMASK(IJ)                                                                                         
            ELSE                                                                                                                    
              SFW = SFW + WL(J) * F(IJ)                                                                                             
              SW  = SW  + WL(J)                                                                                                     
            ENDIF                                                                                                                   
          ELSE                                                                                                                      
            NSP = NSP + 1                                                                                                           
          ENDIF                                                                                                                     
        ENDDO                                                                                                                       
      ENDDO                                                                                                                         
      IF (SW.NE.0.E0)THEN                                                                                                           
        D = SFW/SW                                                                                                                  
      ELSE                                                                                                                          
        D = SPVAL                                                                                                                   
      ENDIF                                                                                                                         
                                                                                                                                    
  175 IF(.NOT.LISTCV) THEN                                                                                                          
C                                                                                                                                   
C       *  PUT THE VALUE OF D INTO F                                                                                                
C                                                                                                                                   
        IF (IBUF(1).EQ.NC4TO8("FOUR")) THEN                                                                                         
          JJ = 0                                                                                                                    
          DO J=1,ILAT                                                                                                               
            JJ = JJ + 1                                                                                                             
            F(JJ) = D                                                                                                               
            DO I=2,ILG                                                                                                              
              JJ = JJ + 1                                                                                                           
              F(JJ) = 0.E0                                                                                                          
            ENDDO                                                                                                                   
          ENDDO                                                                                                                     
        ELSE                                                                                                                        
          DO IJ=1,ILAT*ILG                                                                                                          
C           IF(ABS(F(IJ)-SPVAL).GT.SPVALT)                                                                                          
C    1                                F(IJ) = D                                                                                     
            F(IJ) = D                                                                                                               
          ENDDO                                                                                                                     
        ENDIF                                                                                                                       
C                                                                                                                                   
C       *  PUT F INTO OUTPUT FILE SINT=TAPE2                                                                                        
C                                                                                                                                   
        IF (IUST(2).EQ.1) THEN                                                                                                      
          CALL PUTFLD2(2,F,IBUF,MAXX)                                                                                               
        ENDIF                                                                                                                       
        IF (IUST(3).EQ.1) THEN                                                                                                      
C                                                                                                                                   
C         * SAVE SCALAR                                                                                                             
C                                                                                                                                   
          IBUF(1)=NC4TO8("GRID")                                                                                                    
          IBUF(5)=1                                                                                                                 
          IBUF(6)=1                                                                                                                 
          IBUF(8)=1                                                                                                                 
          CALL PUTFLD2(3,D,IBUF,MAXX)                                                                                               
        ENDIF                                                                                                                       
      ELSE                                                                                                                          
                                                                                                                                    
C                                                                                                                                   
C       * WRITE GLOBAL AVERAGE TO STANDARD OUTPUT                                                                                   
C                                                                                                                                   
                                                                                                                                    
        IF(NSP.EQ.0) THEN                                                                                                           
         WRITE(6,6020) (IBUF(N),N=1,6),D                                                                                            
        ELSE                                                                                                                        
         WRITE(6,6021) (IBUF(N),N=1,6),D,NSP                                                                                        
        ENDIF                                                                                                                       
                                                                                                                                    
      ENDIF                                                                                                                         
                                                                                                                                    
      NFL = NFL + 1                                                                                                                 
                                                                                                                                    
      GO TO 100                                                                                                                     
C----------------------------------------------------------------                                                                   
 6010 FORMAT('   GLOBAVG READ',I5,' FIELDS')                                                                                        
 6020 FORMAT(' FROM ',A4,2X,I10,2X,A4,1X,3I5,                                                                                       
     1       ' SURFACE MEAN IS ',E12.6)                                                                                             
 6021 FORMAT(' FROM ',A4,2X,I10,2X,A4,1X,3I5,                                                                                       
     1       ' SURFACE MEAN IS ',E12.6,' NSPVAL=',I10)                                                                              
      END                                                                                                                           
