      PROGRAM GRIB                                                                                                                  
C     PROGRAM GRIB (GTGRND,      GTEMP,      GU,      GV,      GRIBLK,          D2                                                  
C    1                                                         OUTPUT,  )       D2                                                  
C    2        TAPE1=GTGRND,TAPE2=GTEMP,TAPE3=GU,TAPE4=GV,TAPE7=GRIBLK,                                                              
C    3                                                   TAPE6=OUTPUT)                                                              
C     ----------------------------------------------------------------          D2                                                  
C                                                                               D2                                                  
C     MAR 04/10 - S.KHARIN,F.MAJAESS (CHANGE "RGAS" FROM 287. TO 287.04)        D2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)                                                           
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     MAY 11/83 - R.LAPRISE.                                                                                                        
C                                                                               D2                                                  
CGRIB    - COMPUTES A SERIES OF BULK RICHARDSON'S NUMBER FIELDS         4  1    D1                                                  
C                                                                               D3                                                  
CAUTHOR  - R.LAPRISE                                                            D3                                                  
C                                                                               D3                                                  
CPURPOSE - FROM A TIME SERIES OF GROUND TEMPERATURE (=GTGRND),                  D3                                                  
C          AIR TEMPERATURE (=GTEMP), AND WIND COMPONENTS (=GU,GV),              D3                                                  
C          COMPUTE A SERIES OF BULK RICHARDSONS"S NUMBER FIELDS (=GRIBLK).      D3                                                  
C                                                                               D3                                                  
CINPUT FILES...                                                                 D3                                                  
C                                                                               D3                                                  
C      GTGRND = TIME SERIES OF GROUND TEMPERATURE                               D3                                                  
C      GTEMP  = TIME SERIES OF AIR    TEMPERATURE                               D3                                                  
C      GU     = TIME SERIES OF U WIND COMPONENT                                 D3                                                  
C      GV     = TIME SERIES OF V WIND COMPONENT                                 D3                                                  
C                                                                               D3                                                  
COUTPUT FILE...                                                                 D3                                                  
C                                                                               D3                                                  
C      GRIBLK = SERIES OF BULK RICHARDSONS"S NUMBER FIELDS                      D3                                                  
C----------------------------------------------------------------------------                                                       
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      LOGICAL OK                                                                                                                    
      INTEGER LEV(100)                                                                                                              
C                                                                                                                                   
      COMMON/ICOM/ IBUF(8),IDAT(18528)                                                                                              
C                                                                                                                                   
      COMMON/BLANCK/ GT(18528),T(18528),U(18528),V(18528)                                                                           
      REAL RIB(18528)                                                                                                               
      EQUIVALENCE (RIB,GT)                                                                                                          
C                                                                                                                                   
      DATA MAXX/18528/, RGAS/287.04/, VMINSQ/4.E0/, MAXL/100/                                                                       
C-----------------------------------------------------------------------                                                            
      NFF=6                                                                                                                         
      CALL JCLPNT(NFF,1,2,3,4,7,6)                                                                                                  
      DO 10 LU=1,4                                                                                                                  
   10 REWIND LU                                                                                                                     
C                                                                                                                                   
C                                                                                                                                   
C     * FIND THE LOWEST LEVEL OF AIR TEMPERATURE.                                                                                   
C                                                                                                                                   
      CALL FILEV(LEV,NLEV,IBUF,2)                                                                                                   
      IF((NLEV.LT.1).OR.(NLEV.GT.MAXL)) CALL       XIT(' GRIB',-1)                                                                  
      REWIND 2                                                                                                                      
      LOWH=LEV(NLEV)                                                                                                                
      CALL LVDCODE(SH,LOWH,1)                                                                                                       
      SH=SH/1000.E0                                                                                                                 
      NPTS=IBUF(5)*IBUF(6)                                                                                                          
C                                                                                                                                   
C     * FIND THE LOWEST LEVEL OF WINDS.                                                                                             
C                                                                                                                                   
      CALL FILEV(LEV,NLEV,IBUF,3)                                                                                                   
      IF((NLEV.LT.1).OR.(NLEV.GT.MAXL)) CALL       XIT(' GRIB',-2)                                                                  
      REWIND 3                                                                                                                      
      LOWF=LEV(NLEV)                                                                                                                
      CALL LVDCODE(SF,LOWF,1)                                                                                                       
      SF=SF/1000.E0                                                                                                                 
C                                                                                                                                   
C     * GET THE LOWEST LEVEL OF AIR TEMPERATURE.                                                                                    
C                                                                                                                                   
      NRECS=0                                                                                                                       
  100 CALL GETFLD2(2,T,NC4TO8("GRID"),-1,NC4TO8("TEMP"),LOWH,                                                                       
     +                                          IBUF,MAXX,OK)                                                                       
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030)NRECS                                                                                                          
        CALL                                       XIT(' GRIB', 0)                                                                  
      ENDIF                                                                                                                         
      IF(IBUF(5)*IBUF(6).NE.NPTS) CALL             XIT(' GRIB',-3)                                                                  
      IF(NRECS.EQ.0) WRITE(6,6025)IBUF                                                                                              
      NT=IBUF(2)                                                                                                                    
C                                                                                                                                   
C     * GET THE GROUND TEMPERATURE FOR THE CORRESPONDING TIMESTEP.                                                                  
C                                                                                                                                   
      CALL GETFLD2(1,GT,NC4TO8("GRID"),NT,NC4TO8("  GT"),-1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT(' GRIB',-4)                                                                  
      IF(IBUF(5)*IBUF(6).NE.NPTS) CALL             XIT(' GRIB',-5)                                                                  
      IF(NRECS.EQ.0) WRITE(6,6025)IBUF                                                                                              
C                                                                                                                                   
C     * GET THE LOW LEVEL WIND COMPONENTS FOR CORRESPONDING TIMESTEP.                                                               
C                                                                                                                                   
      CALL GETFLD2(3,U,NC4TO8("GRID"),NT,NC4TO8("   U"),LOWF,                                                                       
     +                                          IBUF,MAXX,OK)                                                                       
      IF(.NOT.OK) CALL                             XIT(' GRIB',-6)                                                                  
      IF(IBUF(5)*IBUF(6).NE.NPTS) CALL             XIT(' GRIB',-7)                                                                  
      IF(NRECS.EQ.0) WRITE(6,6025)IBUF                                                                                              
C                                                                                                                                   
      CALL GETFLD2(4,V,NC4TO8("GRID"),NT,NC4TO8("   V"),LOWF,                                                                       
     +                                          IBUF,MAXX,OK)                                                                       
      IF(.NOT.OK) CALL                             XIT(' GRIB',-8)                                                                  
      IF(IBUF(5)*IBUF(6).NE.NPTS) CALL             XIT(' GRIB',-9)                                                                  
      IF(NRECS.EQ.0) WRITE(6,6025)IBUF                                                                                              
C                                                                                                                                   
C     * COMPUTE THE BULK RICHARDSON"S NUMBER AS IN THE MODEL.                                                                       
C     * RIB = G*H*(THETAS-THETAG) / (THETAS*WINDS**2)                                                                               
C                                                                                                                                   
      DS=(1.E0-SF)**2 / (1.E0-SH)                                                                                                   
      SEXPKH=SH**(2.E0/7.E0)                                                                                                        
      DO 200 I=1,NPTS                                                                                                               
      WINDSQ=MAX(U(I)**2+V(I)**2,VMINSQ)                                                                                            
  200 RIB(I)=-RGAS*(GT(I)-T(I)/SEXPKH)*DS/WINDSQ                                                                                    
C                                                                                                                                   
C     * SAVE RIB.                                                                                                                   
C                                                                                                                                   
      IBUF(3)=NC4TO8(" RIB")                                                                                                        
      IBUF(4)=1                                                                                                                     
      CALL PUTFLD2(7,RIB,IBUF,MAXX)                                                                                                 
      IF(NRECS.EQ.0) WRITE(6,6025)IBUF                                                                                              
      NRECS=NRECS+1                                                                                                                 
      GO TO 100                                                                                                                     
C-----------------------------------------------------------------------                                                            
 6025 FORMAT(' ',A4,I10,2X,A4,I10,4I6)                                                                                              
 6030 FORMAT('0',I5,' FIELDS SAVED')                                                                                                
      END                                                                                                                           
