      PROGRAM VEINT                                                                                                                 
C     PROGRAM VEINT (XIN,      XOUT,      INPUT,      OUTPUT,           )       J2                                                  
C    1         TAPE1=XIN,TAPE2=XOUT,TAPE5=INPUT,TAPE6=OUTPUT)                                                                       
C     -------------------------------------------------------                   J2                                                  
C                                                                               J2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       J2                                                  
C     DEC 06/93 - D. LIU                                                                                                            
C                                                                               J2                                                  
CVEINT   - VERTICAL ETA INTEGRAL FOR DATA ON ETA COORDINATES            1  1 C  J1                                                  
C                                                                               J3                                                  
CAUTHOR  - D. LIU (BASE ON VSINTH BY R. LAPRISE)                                J3                                                  
C                                                                               J3                                                  
CPURPOSE - COMPUTES THE VERTICAL ETA INTEGRAL FOR DATA ON ETA COORDINATES.      J3                                                  
C          SPECTRAL FIELDS CAN NOT BE HANDLED IN ETA COORD.                     J3                                                  
C                                                                               J3                                                  
CINPUT FILE...                                                                  J3                                                  
C                                                                               J3                                                  
C      XIN  = INPUT SERIES OF ETA LEVEL GRID FIELDS .                           J3                                                  
C                                                                               J3                                                  
COUTPUT FILE...                                                                 J3                                                  
C                                                                               J3                                                  
C      XOUT = OUTPUT SERIES OF VERTICAL ETA INTEGRALS OF XIN.                   J3                                                  
C                                                                                                                                   
CINPUT PARAMETERS...                                                                                                                
C                                                                               J5                                                  
C      LEVTYP = FULL FOR MOMENTUM VARIABLE, AND                                 J5                                                  
C               HALF FOR THERMODYNAMIC ONE.                                     J5                                                  
C      CONST  = SCALES THE OUTPUT FIELD.                                        J5                                                  
C      LAY    = DEFINES THE POSITION OF LAYER INTERFACES IN RELATION            J5                                                  
C               TO LAYER CENTRES (SEE BASCAL).                                  J5                                                  
C               (ZERO DEFAULTS TO THE FORMER STAGGERING CONVENTION).            J5                                                  
C      ICOORD = 4H ETA FOR ETA LEVELS OF INPUT FIELDS (ANY OTHER VALUE WILL     J5                                                  
C                              RESULT IN THE PROGRAM ABORTING)                  J5                                                  
C      SIGTOP = VALUE OF SIGMA AT TOP OF DOMAIN FOR VERTICAL INTEGRAL.          J5                                                  
C               IF .LT.0., THEN INTERNALLY DEFINED BASED ON LEVTYP              J5                                                  
C               FOR UPWARD COMPATIBILITY.                                       J5                                                  
C      PTOIT  = PRESSURE (PA) OF THE RIGID LID OF THE MODEL.                    J5                                                  
C                                                                               J5                                                  
C      NOTE - LAY AND LEVTYP DEFINE THE TYPE OF LEVELLING FOR THE VARIABLE.     J5                                                  
C                                                                               J5                                                  
CEXAMPLE OF INPUT CARD...                                                       J5                                                  
C                                                                               J5                                                  
C*VEINT    HALF 10.197671    3  ETA-1.00       50.                              J5                                                  
C------------------------------------------------------------------------------                                                     
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      LOGICAL OK,SPEC                                                                                                               
                                                                                                                                    
      INTEGER LEV(100)                                                                                                              
                                                                                                                                    
      REAL ETA (100), ETAB (100), E(2)                                                                                              
                                                                                                                                    
      COMMON /BLANCK/ PSMBLN(18528), ACC(18528), GG(18528)                                                                          
                                                                                                                                    
      COMMON /ICOM  /IBUF(8),IDAT(18528)                                                                                            
                                                                                                                                    
      DATA MAXX/18528/, MAXLEV/100/                                                                                                 
                                                                                                                                    
      PARAMETER(P0=101320.E0)                                                                                                       
                                                                                                                                    
C---------------------------------------------------------------------                                                              
      NFIL = 4                                                                                                                      
      CALL JCLPNT(NFIL,1,2,5,6)                                                                                                     
      REWIND 1                                                                                                                      
      REWIND 2                                                                                                                      
                                                                                                                                    
C     * READ CONTROL DIRECTIVES.                                                                                                    
                                                                                                                                    
      READ(5,5010,END=900) LEVTYP,CONST,LAY,ICOORD,SIGTOP,PTOIT                 J4                                                  
      IF(ICOORD.NE.NC4TO8(" ETA")) CALL            XIT('VEINT',-1)                                                                  
      PTOIT=MAX(PTOIT, 0.100E-09)                                                                                                   
      WRITE(6,6005) LEVTYP,CONST,LAY,ICOORD,SIGTOP,PTOIT                                                                            
                                                                                                                                    
C     * GET ETA VALUES OF LAYER CENTRES FROM XIN.                                                                                   
                                                                                                                                    
      CALL FILEV (LEV,ILEV,IBUF,1)                                                                                                  
      IF(ILEV.LT.1 .OR. ILEV.GT.MAXLEV)  CALL      XIT('VEINT',-2)                                                                  
      WRITE(6,6007) ILEV,(LEV(L),L=1,ILEV)                                                                                          
                                                                                                                                    
      CALL LVDCODE(ETA,LEV,ILEV)                                                                                                    
      DO 150 L=1,ILEV                                                                                                               
         ETA(L)=ETA(L)*0.001E0                                                                                                      
  150 CONTINUE                                                                                                                      
                                                                                                                                    
C     * DETERMINE THE FIELD SIZE.                                                                                                   
                                                                                                                                    
      KIND=IBUF(1)                                                                                                                  
      NAME=IBUF(3)                                                                                                                  
      SPEC=(KIND.EQ.NC4TO8("SPEC") .OR. KIND.EQ.NC4TO8("FOUR"))                                                                     
      NWDS=IBUF(5)*IBUF(6)                                                                                                          
      IF(SPEC)   CALL                              XIT('VEINT',-3)                                                                  
                                                                                                                                    
C     * EVALUATE LAYER INTERFACES FROM LEVTYP AND LAY.                                                                              
                                                                                                                                    
      IF    (LEVTYP.EQ.NC4TO8("FULL")) THEN                                                                                         
         CALL BASCAL (ETAB,IBUF, ETA,ETA,ILEV,LAY)                                                                                  
      ELSEIF(LEVTYP.EQ.NC4TO8("HALF")) THEN                                                                                         
         CALL BASCAL (IBUF,ETAB, ETA,ETA,ILEV,LAY)                                                                                  
      ELSE                                                                                                                          
         CALL                                      XIT('VEINT',-4)                                                                  
      ENDIF                                                                                                                         
                                                                                                                                    
C---------------------------------------------------------------------                                                              
      NSETS=0                                                                                                                       
  200 CONTINUE                                                                                                                      
                                                                                                                                    
C     * INITIALIZE THE CUMULATIVE ARRAY.                                                                                            
                                                                                                                                    
      DO 400 I=1,NWDS                                                                                                               
         ACC (I)     = 0.E0                                                                                                         
  400 CONTINUE                                                                                                                      
                                                                                                                                    
      IGH = 1                                                                                                                       
      LOW = 2                                                                                                                       
      E(IGH)=PTOIT/P0                                                                                                               
                                                                                                                                    
                                                                                                                                    
C     * PROCESS ALL LEVELS AND ACCUMULATE ETA VERTICAL INTEGRAL.                                                                    
                                                                                                                                    
      DO 800 L=1,ILEV                                                                                                               
                                                                                                                                    
         CALL GETFLD2 (1,GG,KIND,-1,-1,LEV(L),IBUF,MAXX,OK)                                                                         
         IF(NSETS.EQ.0) WRITE(6,6025) IBUF                                                                                          
         IF(.NOT.OK) THEN                                                                                                           
            IF(NSETS.GT.0) THEN                                                                                                     
               WRITE(6,6025) IBUF                                                                                                   
               WRITE(6,6020) NSETS                                                                                                  
               CALL                                XIT('VEINT',0)                                                                   
            ELSE                                                                                                                    
               CALL                                XIT('VEINT',-10-L)                                                               
            ENDIF                                                                                                                   
         ENDIF                                                                                                                      
                                                                                                                                    
         E(LOW)=ETAB(L)                                                                                                             
                                                                                                                                    
         DO 500 I=1,NWDS                                                                                                            
            ACC(I) = ACC(I) + GG(I)*CONST*(E(LOW)-E(IGH))                                                                           
  500    CONTINUE                                                                                                                   
                                                                                                                                    
         KEEP= LOW                                                                                                                  
         LOW = IGH                                                                                                                  
         IGH = KEEP                                                                                                                 
                                                                                                                                    
                                                                                                                                    
  800 CONTINUE                                                                                                                      
                                                                                                                                    
C     * PUT THE RESULT ONTO FILE XOUT.                                                                                              
                                                                                                                                    
      IBUF(4)=1                                                                                                                     
      CALL PUTFLD2 (2,ACC,IBUF,MAXX)                                                                                                
      NSETS=NSETS+1                                                                                                                 
                                                                                                                                    
      GO TO 200                                                                                                                     
                                                                                                                                    
C     * E.O.F. ON INPUT.                                                                                                            
                                                                                                                                    
  900 CALL                                         XIT('VEINT',-5)                                                                  
C---------------------------------------------------------------------                                                              
 5010 FORMAT(11X,A4,E10.0,I5,1X,A4,E5.0,E10.0)                                  J4                                                  
 6005 FORMAT('  LEVTYP = ',A4,', CONST = ',1P,E12.4,                                                                                
     1       ', LAY = ',0P,I5,', COORD=',1X,A4,', SIGTOP =',F15.10,                                                                 
     2       ', P.LID (PA)=',E10.3)                                                                                                 
 6007 FORMAT(' ILEV,ETA =',I5,2X,20I5/(18X,20I5))                                                                                   
 6020 FORMAT('0',I6,' SETS WERE PROCESSED')                                                                                         
 6025 FORMAT(' ',A4,I10,2X,A4,5I10)                                                                                                 
      END                                                                                                                           
