      PROGRAM PGEN                                                                                                                  
C     PROGRAM PGEN (INF,       POUT,       OUTPUT,                      )       C2                                                  
C    1        TAPE1=INF, TAPE2=POUT, TAPE6=OUTPUT)                                                                                  
C     --------------------------------------------                              C2                                                  
C                                                                               C2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       C2                                                  
C     MAR 05/02 - F.MAJAESS (REVISED FOR "CHAR" KIND RECORDS)                                                                       
C     JAN 14/93 - E. CHAN  (DECODE LEVELS IN 8-WORD LABEL)                                                                          
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     NOV 29/83 - B. DUGAS.                                                                                                         
C                                                                               C2                                                  
CPGEN    - CREATES A FILE WITH VALUES SET EQUAL TO PRESSURE LEVEL       1  1    C1                                                  
C                                                                               C3                                                  
CAUTHOR  - B.DUGAS                                                              C3                                                  
C                                                                               C3                                                  
CPURPOSE - GENERATES A FILE WHOSE VALUES ARE SET TO THE PRESSURE LEVEL          C3                                                  
C          VALUE FOUND IN IBUF(4).                                              C3                                                  
C          NOTE - FOR FOURIER AND SPECTRAL TYPE FILES, ONLY PART OF             C3                                                  
C                 THE RECORD VALUES ARE SET EQUAL TO THE PRESSURE               C3                                                  
C                 VALUE FOUND IN IBUF(4).                                       C3                                                  
CINPUT FILE...                                                                  C3                                                  
C                                                                               C3                                                  
C      INF  = FILE CONTAINING RECORDS AT PRESSURE LEVEL(S), IT CAN BE           C3                                                  
C             OF TYPE SPECTRAL, FOURIER COEF., ZONAL CROSS-SECTIONS OR          C3                                                  
C             GAUSSIAN GRID(S).                                                 C3                                                  
C                                                                               C3                                                  
COUTPUT FILE...                                                                 C3                                                  
C                                                                               C3                                                  
C      POUT = FILE OF THE SAME TYPE AS INF WITH THE VALUE(S) OF EACH RECORD     C3                                                  
C             SET EQUAL TO THE PRESSURE LEVEL VALUE (MB) FOUND IN IBUF(4).      C3                                                  
C---------------------------------------------------------------------------                                                        
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMMON/F/F(18528)                                                                                                             
      COMMON/ICOM/IBUF(8),IDAT(18528)                                                                                               
C                                                                                                                                   
      LOGICAL OK                                                                                                                    
      DATA MAXX/18528/                                                                                                              
C-------------------------------------------------------------------                                                                
      NFF=3                                                                                                                         
      CALL JCLPNT(NFF,1,2,6)                                                                                                        
      REWIND 1                                                                                                                      
      REWIND 2                                                                                                                      
C                                                                                                                                   
C     *  READ IN THE FIRST FIELD IN INF.                                                                                            
C                                                                                                                                   
      NF = 0                                                                                                                        
  100 CALL GETFLD2 (1,F,-1,-1,-1,-1,IBUF,MAXX,OK)                                                                                   
      IF(.NOT.OK)THEN                                                                                                               
        IF(NF.EQ.0)THEN                                                                                                             
          CALL                                     XIT('PGEN',-1)                                                                   
        ELSE                                                                                                                        
          WRITE(6,6020) IBUF                                                                                                        
          WRITE(6,6010) NF                                                                                                          
          CALL                                     XIT('PGEN',0)                                                                    
        ENDIF                                                                                                                       
      ENDIF                                                                                                                         
      IF (NF.EQ.0) WRITE(6,6020) IBUF                                                                                               
      CALL LVDCODE(ALEV,IBUF(4),1)                                                                                                  
      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('PGEN',-2)                                                                   
C                                                                                                                                   
C     *  SPECTRAL CASE.                                                                                                             
C                                                                                                                                   
  110 F(1) = ALEV * SQRT(2.E0)                                                                                                      
      LA2 = IBUF(5)*2                                                                                                               
      DO 115 I=2,LA2                                                                                                                
      F(I) = 0.E0                                                                                                                   
  115 CONTINUE                                                                                                                      
      GO TO 230                                                                                                                     
C                                                                                                                                   
C     *  ZONAL CASE.                                                                                                                
C                                                                                                                                   
  120 ILAT = IBUF(5)                                                                                                                
      DO 130 J=1,ILAT                                                                                                               
      F(J) = ALEV                                                                                                                   
  130 CONTINUE                                                                                                                      
      GO TO 230                                                                                                                     
C                                                                                                                                   
C     *  FOURIER CASE.                                                                                                              
C                                                                                                                                   
  140 ILAT=IBUF(6)                                                                                                                  
      LR=IBUF(5) * 2                                                                                                                
      DO 150 J=1,ILAT                                                                                                               
      JJ = (J - 1) * LR + 1                                                                                                         
      F(JJ) = ALEV                                                                                                                  
      DO 150 I=2,LR                                                                                                                 
      JJ = JJ + 1                                                                                                                   
      F(JJ) = 0.E0                                                                                                                  
  150 CONTINUE                                                                                                                      
      GO TO 230                                                                                                                     
C                                                                                                                                   
C     *  GRID CASE.                                                                                                                 
C                                                                                                                                   
  160 ILG = IBUF(5)                                                                                                                 
      ILAT = IBUF(6)                                                                                                                
      DO 190 J=1,ILAT                                                                                                               
      DO 190 I=1,ILG                                                                                                                
      IJ = (J - 1) * ILG + I                                                                                                        
      F(IJ) = ALEV                                                                                                                  
  190 CONTINUE                                                                                                                      
C                                                                                                                                   
C     *  PUT F INTO OUTPUT FILE POUT = TAPE2.                                                                                       
C                                                                                                                                   
  230 IBUF(8) = 4                                                                                                                   
      IBUF(3)=NC4TO8("PRES")                                                                                                        
      CALL PUTFLD2(2,F,IBUF,MAXX)                                                                                                   
      NF = NF + 1                                                                                                                   
      GO TO 100                                                                                                                     
C----------------------------------------------------------------                                                                   
 6010 FORMAT('   PGEN READ',I5,' FIELDS')                                                                                           
 6020 FORMAT('  PGEN ON ',A5,2X,I10,A5,5(2X,I5))                                                                                    
      END                                                                                                                           
