      PROGRAM WASCALE                                                   
C     PROGRAM WASCALE (XIN,       XOUT,       OUTPUT,                   
C    1          TAPE1=XIN, TAPE2=XOUT, TAPE6=OUTPUT)                    
C     ----------------------------------------------                    
C                                                                       
C     FEB 29/2016 - Y.JIAO                                              
C                                                                       
CWASCALE  - SCALE WA WITH (7000./PLEV)**2                               
C                                                                       
CINPUT FILE...                                                          
C                                                                       
C      XIN  = INPUT FILE                                                
C                                                                       
COUTPUT FILE...                                                         
C                                                                       
C      XOUT = XIN * (7000./PLEV)**2)         PLEV in Pa                 
C-----------------------------------------------------------------------
C                                                                       
      IMPLICIT REAL (A-H,O-Z),                                          
     +INTEGER (I-N)                                                     
      COMMON/BLANCK/F(308321)                                           

      INTEGER  LEV(100)
      REAL    RLEV(100)
C                                                                       
      LOGICAL OK,SPEC                                                   
      COMMON/ICOM/IBUF(8),IDAT(616642)                                  
      DATA MAXX/616642/                                                 
C---------------------------------------------------------------------  
      NFF=3                                                             
      CALL JCLPNT(NFF,1,2,6)                                            
      REWIND 1                                                          
      REWIND 2                                                          
C                                                                       
C     * READ THE NEXT GRID FROM FILE XIN.                               
C     CALL FILEV(LEV,NLEV,IBUF,1)
C     CALL LVDCODE(RLEV,LEV,NLEV)
C                                                                       
      NR=0                                                              
  150 CALL GETFLD2(1,F,-1,0,0,0,IBUF,MAXX,OK)                           
      IF(.NOT.OK)THEN                                                   
        IF(NR.EQ.0)THEN                                                 
          CALL                                     XIT('WASCALE',-1)    
        ELSE                                                            
          WRITE(6,6025) IBUF                                            
          WRITE(6,6010) NR                                              
          CALL                                     XIT('WASCALE',0)     
        ENDIF                                                           
      ENDIF                                                             
      IF(NR.EQ.0) WRITE(6,6025) IBUF                                    
C                                                                       
C     * DETERMINE SIZE OF THE FIELD.                                    
C                                                                       
      KIND=IBUF(1)                                                      
      SPEC=(KIND.EQ.NC4TO8("SPEC") .OR. KIND.EQ.NC4TO8("FOUR"))         
      IF(SPEC) CALL                                XIT('WASCALE',-2)    

C                                                                       
C     * PERFORM THE ALGEBRAIC OPERATION.                                
C                                                                       
      NWDS=IBUF(5)*IBUF(6)                                              
      CALL LVDCODE(PLEV,IBUF(4),1)
      IF(PLEV.GT.99000.0) PLEV=(PLEV-99000.0)/10.0

c     write(6,'(i8,f15.8)')IBUF(4),PLEV

      DO 210 I=1,NWDS                                                   
  210 F(I)=F(I)*(70./PLEV)**2
C                                                                       
C     * SAVE ON FILE XOUT.                                              
C                                                                       
      CALL PUTFLD2(2,F,IBUF,MAXX)                                       
      NR=NR+1                                                           
      GO TO 150                                                         
C---------------------------------------------------------------------  
 6010 FORMAT('0 WASCALE READ',I6,' RECORDS')                            
 6025 FORMAT(' ',A4,I10,2X,A4,I10,4I6)                                  
      END                                                               
