      PROGRAM VPINT                                                                                                                 
C     PROGRAM VPINT (XIN,       XOUT,       OUTPUT,                     )       C2                                                  
C    1         TAPE1=XIN, TAPE2=XOUT, TAPE6=OUTPUT)                                                                                 
C     ---------------------------------------------                             C2                                                  
C                                                                               C2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       C2                                                  
C     JAN 14/93 - E. CHAN  (DECODE LEVELS IN 8-WORD LABEL)                                                                          
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     MAR 10/86 - B.DUGAS                                                                                                           
C                                                                               C2                                                  
CVPINT   - VERTICAL PRESSURE INTEGRAL OF FIELDS IN A FILE               1  1    C1                                                  
C                                                                               C3                                                  
CAUTHOR  - J.D.HENDERSON                                                        C3                                                  
C                                                                               C3                                                  
CPURPOSE - COMPUTES THE VERTICAL INTEGRATION OF A FILE OF PRESSURE LEVEL        C3                                                  
C          SETS USING TRAPEZOIDAL QUADRATURE FROM 0. TO 1013.3 MB.              C3                                                  
C          NOTE - FILE XIN MAY CONTAIN SEVERAL FIELDS.                          C3                                                  
C                 MINIMUM NUMBER OF LEVELS IS 2, MAX IS $PL$.                   C3                                                  
C                                                                               C3                                                  
CINPUT FILE...                                                                  C3                                                  
C                                                                               C3                                                  
C      XIN = FILE OF PRESSURE LEVEL SETS                                        C3                                                  
C                                                                               C3                                                  
COUTPUT FILE...                                                                 C3                                                  
C                                                                               C3                                                  
C      XOUT = VERTICAL PRESSURE INTEGRALS OF THE SETS IN XIN.                   C3                                                  
C-----------------------------------------------------------------------------                                                      
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMMON/BLANCK/GG(18528),ACC(18528)                                                                                            
                                                                                                                                    
      LOGICAL OK,SPEC                                                                                                               
      INTEGER LEV(100)                                                                                                              
      REAL PRH(101),PR(100)                                                                                                         
                                                                                                                                    
      COMMON/ICOM/IBUF(8),IDAT(18528)                                                                                               
      DATA MAXX/18528/, MAXL/100/                                                                                                   
C---------------------------------------------------------------------                                                              
                                                                                                                                    
      NF   = 3                                                                                                                      
      CALL JCLPNT(NF,1,2,6)                                                                                                         
      REWIND 1                                                                                                                      
      REWIND 2                                                                                                                      
                                                                                                                                    
      GINV = 1.E0/9.80616E0                                                                                                         
                                                                                                                                    
C     * FIND HOW MANY LEVELS THERE ARE.                                                                                             
                                                                                                                                    
      CALL FILEV(LEV,NLEV,IBUF,1)                                                                                                   
      IF (NLEV.LT.2 .OR. NLEV.GT.MAXL) CALL        XIT('VPINT',-1)                                                                  
      WRITE(6,6025) IBUF                                                                                                            
      WRITE(6,6005) NLEV,(LEV(I),I=1,NLEV)                                                                                          
                                                                                                                                    
C     * DETERMINE THE FIELD SIZE.                                                                                                   
                                                                                                                                    
      KIND = IBUF(1)                                                                                                                
      SPEC = (KIND.EQ.NC4TO8("SPEC") .OR. KIND.EQ.NC4TO8("FOUR"))                                                                   
      NWDS = IBUF(5)*IBUF(6)                                                                                                        
      IF (SPEC) NWDS = NWDS*2                                                                                                       
                                                                                                                                    
C     * COMPUTE PRESSURE HALF LEVELS FOR INTEGRAL IN P.                                                                             
C     * BOTTOM LEVEL IS ARBITRARILY SET TO 1013.3 MB.                                                                               
                                                                                                                                    
      CALL LVDCODE(PR,LEV,NLEV)                                                                                                     
      PRH(1)      = GINV*PR(1)*50.E0                                                                                                
      DO 110 L=2,NLEV                                                                                                               
         PRH(L)   = GINV*(PR(L)+PR(L-1))*50.E0                                                                                      
  110 CONTINUE                                                                                                                      
      PRH(NLEV+1) = 101330.E0*GINV                                                                                                  
                                                                                                                                    
C     * READ THE NEXT SET.                                                                                                          
                                                                                                                                    
      NSETS = 0                                                                                                                     
  150 CALL GETFLD2(1,ACC,KIND,-1,-1,LEV(1),IBUF,MAXX,OK)                                                                            
                                                                                                                                    
          IF (.NOT.OK)                                         THEN                                                                 
              IF (NSETS.EQ.0)                                  THEN                                                                 
                  WRITE(6,6010)                                                                                                     
                  CALL                             XIT('VPINT',-2)                                                                  
              END IF                                                                                                                
              WRITE(6,6020) NSETS                                                                                                   
              CALL                                 XIT('VPINT',0)                                                                   
          END IF                                                                                                                    
                                                                                                                                    
          ITIM = IBUF(2)                                                                                                            
          NAME = IBUF(3)                                                                                                            
                                                                                                                                    
C         * INTEGRATE THE GRIDS IN THE VERTICAL AND DIVIDE BY G.                                                                    
                                                                                                                                    
          DP = (PRH(2)-PRH(1))                                                                                                      
          DO 200 I=1,NWDS                                                                                                           
              ACC(I) = ACC(I)*DP                                                                                                    
  200     CONTINUE                                                                                                                  
                                                                                                                                    
          DO 500 L=2,NLEV                                                                                                           
                                                                                                                                    
              CALL GETFLD2(1,GG,KIND,ITIM,NAME,LEV(L),IBUF,MAXX,OK)                                                                 
                                                                                                                                    
              IF (.NOT.OK) CALL                    XIT(' VPINT',-10-L)                                                              
                                                                                                                                    
              DP = (PRH(L+1)-PRH(L))                                                                                                
              DO 400 I=1,NWDS                                                                                                       
                  ACC(I) = ACC(I)+GG(I)*DP                                                                                          
  400         CONTINUE                                                                                                              
                                                                                                                                    
  500     CONTINUE                                                                                                                  
                                                                                                                                    
C         * PUT THE RESULT ONTO FILE 2.                                                                                             
                                                                                                                                    
          IBUF(4) = 1                                                                                                               
          CALL PUTFLD2(2,ACC,IBUF,MAXX)                                                                                             
                                                                                                                                    
      NSETS = NSETS+1                                                                                                               
      GOTO 150                                                                                                                      
                                                                                                                                    
C---------------------------------------------------------------------                                                              
 6005 FORMAT('0 VPINT ON ',I5,' LEVELS = ',20I5/(24X,20I5)/)                                                                        
 6010 FORMAT('0.. VPINT INPUT FILE IS EMPTY')                                                                                       
 6020 FORMAT('0',I6,' SETS WERE PROCESSED')                                                                                         
 6025 FORMAT(' ',A4,I10,2X,A4,I10,4I6)                                                                                              
      END                                                                                                                           
