      PROGRAM GSAPL                                                                                                                 
C     PROGRAM  GSAPL (GSFLD,       GSLNSP,       GPFLD,       INPUT,            J2                                                  
C    1                                                        OUTPUT,   )       J2                                                  
C    2          TAPE1=GSFLD, TAPE2=GSLNSP, TAPE3=GPFLD, TAPE5=INPUT,                                                                
C    3                                                  TAPE6=OUTPUT)                                                               
C     ---------------------------------------------------------------           J2                                                  
C                                                                               J2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       J2                                                  
C     JAN 12/93 - E. CHAN  (DECODE LEVELS IN 8-WORD LABEL)                                                                          
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     FEB 29/88 - R.LAPRISE.                                                                                                        
C                                                                               J2                                                  
CGSAPL   - INTERPOLATES FROM SIGMA/HYBRID LEVELS TO NPL PRES. LEVELS    2  1 C  J1                                                  
C                                                                               J3                                                  
CAUTHOR  - R. LAPRISE                                                           J3                                                  
C                                                                               J3                                                  
CPURPOSE - INTERPOLATES FROM ETA (SIGMA/HYBRID) LEVELS TO NPL                   J3                                                  
C          PRESSURE LEVELS. THE INTERPOLATION IS LINEAR IN LN(SIGMA).           J3                                                  
C          EXTRAPOLATION UP AND DOWN IS BY LAPSE RATES SPECIFIED BY             J3                                                  
C          THE USER.                                                            J3                                                  
C                                                                               J3                                                  
CINPUT FILES...                                                                 J3                                                  
C                                                                               J3                                                  
C      GSFLD  = SETS OF ETA (SIGMA/HYBRID) LEVEL GRID DATA.                     J3                                                  
C      GSLNSP = SERIES OF GRIDS OF LN(SF PRES).                                 J3                                                  
C                                                                               J3                                                  
COUTPUT FILE...                                                                 J3                                                  
C                                                                               J3                                                  
C      GPFLD  = SETS OF PRESSURE LEVEL GRID DATA.                               J3                                                  
C                                                                                                                                   
CINPUT PARAMETERS...                                                                                                                
C                                                                               J5                                                  
C      NPL    = NUMBER OF REQUESTED PRESSURE LEVELS, (MAX $L$).                 J5                                                  
C      RLUP   = LAPSE RATE USED TO EXTRAPOLATE UPWARDS.                         J5                                                  
C      RLDN   = LAPSE RATE USED TO EXTRAPOLATE DOWNWARDS.                       J5                                                  
C      ICOORD = 4H SIG/ 4H ETA FOR SIGMA/ETA VERTICAL COORDINATES.              J5                                                  
C      PTOIT  = PRESSURE (PA) AT THE LID OF MODEL.                              J5                                                  
C      PR     = PRESSURE LEVELS (MB)                                            J5                                                  
C                                                                               J5                                                  
CEXAMPLE OF INPUT CARDS...                                                      J5                                                  
C                                                                               J5                                                  
C*GSAPL.      5        0.        0.  SIG        0.                              J5                                                  
C*100  300  500  850 1000                                                       J5                                                  
C----------------------------------------------------------------------------                                                       
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      LOGICAL OK                                                                                                                    
                                                                                                                                    
      INTEGER LEV(100),LEVP(100),KBUF(8)                                                                                            
                                                                                                                                    
      REAL ETA  (100),A    (100),B      (100)                                                                                       
      REAL SIG  (100),FSIG (100),DFLNSIG(101),DLNSIG (100)                                                                          
      REAL PR   (100),PRLOG(100)                                                                                                    
                                                                                                                                    
      COMMON/BLANCK/F(1871328)                                                                                                      
      COMMON/ICOM  /IBUF(8),IDAT(18528)                                                                                             
                                                                                                                                    
      DATA MAXX/18528/, MAXL/1871328/, MAXLEV/100/                                                                                  
C---------------------------------------------------------------------                                                              
      NFIL=5                                                                                                                        
      CALL JCLPNT(NFIL,1,2,3,5,6)                                                                                                   
      DO 110 N=1,3                                                                                                                  
  110 REWIND N                                                                                                                      
                                                                                                                                    
C     * READ THE CONTROL CARDS.                                                                                                     
                                                                                                                                    
      READ(5,5010,END=908) NPL,RLUP,RLDN,ICOORD,PTOIT                           J4                                                  
      IF(ICOORD.EQ.NC4TO8("    ")) ICOORD=NC4TO8(" SIG")                                                                            
      IF(ICOORD.EQ.NC4TO8(" SIG")) THEN                                                                                             
        PTOIT=MAX(PTOIT,0.00E0)                                                                                                     
      ELSE                                                                                                                          
        PTOIT=MAX(PTOIT, 0.100E-09)                                                                                                 
      ENDIF                                                                                                                         
      IF(NPL.GT.MAXLEV) CALL                       XIT('GSAPL',-1)                                                                  
      READ(5,5020,END=909) (LEVP(I),I=1,NPL)                                    J4                                                  
                                                                                                                                    
C     * DECODE LEVELS.                                                                                                              
                                                                                                                                    
      CALL LVDCODE(PR,LEVP,NPL)                                                                                                     
                                                                                                                                    
      WRITE(6,6010) RLUP,RLDN,ICOORD,PTOIT                                                                                          
      CALL WRITLEV(PR,NPL,' PR ')                                                                                                   
                                                                                                                                    
      DO 114 L=2,NPL                                                                                                                
  114 IF(PR(L).LE.PR(L-1)) CALL                    XIT('GSAPL',-2)                                                                  
                                                                                                                                    
      DO 130 L=1,NPL                                                                                                                
  130 PRLOG(L)=LOG(PR(L))                                                                                                           
                                                                                                                                    
C     * GET ETA VALUES FROM THE GSFLD FILE.                                                                                         
                                                                                                                                    
      CALL FILEV (LEV,NSL,IBUF,1)                                                                                                   
      IF(NSL.LT.1 .OR. NSL.GT.MAXLEV) CALL         XIT('GSAPL',-3)                                                                  
      NWDS = IBUF(5)*IBUF(6)                                                                                                        
      IF((MAX(NSL,NPL)+1)*NWDS.GT.MAXL) CALL      XIT('GSAPL',-4)                                                                   
      DO 116 I=1,8                                                                                                                  
  116 KBUF(I)=IBUF(I)                                                                                                               
      CALL LVDCODE(ETA,LEV,NSL)                                                                                                     
      DO 118 L=1,NSL                                                                                                                
  118 ETA(L)=ETA(L)*0.001E0                                                                                                         
                                                                                                                                    
C     * EVALUATE THE PARAMETERS OF THE ETA VERTICAL DISCRETIZATION.                                                                 
                                                                                                                                    
      CALL COORDAB (A,B, NSL,ETA, ICOORD,PTOIT)                                                                                     
C---------------------------------------------------------------------                                                              
C     * GET NEXT SET FROM FILE GSFLD.                                                                                               
                                                                                                                                    
      NSETS=0                                                                                                                       
      N=NWDS+1                                                                                                                      
  150 CALL GETSET2 (1,F(N),LEV,NSL,IBUF,MAXX,OK)                                                                                    
      IF(NSETS.EQ.0) WRITE(6,6035) IBUF                                                                                             
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) NSETS                                                                                                         
        IF(NSETS.EQ.0)THEN                                                                                                          
          CALL                                     XIT('GSAPL',-5)                                                                  
        ELSE                                                                                                                        
          CALL                                     XIT('GSAPL',0)                                                                   
        ENDIF                                                                                                                       
      ENDIF                                                                                                                         
      CALL CMPLBL (0,IBUF,0,KBUF,OK)                                                                                                
      IF(.NOT.OK) CALL                             XIT('GSAPL',-6)                                                                  
      NAME=IBUF(3)                                                                                                                  
      NPACK=IBUF(8)                                                                                                                 
                                                                                                                                    
C     * GET LN(SF PRES) FOR THIS STEP, PUT AT BEGINNING OF COMMON BLOCK.                                                            
                                                                                                                                    
      NST= IBUF(2)                                                                                                                  
      CALL GETFLD2 (2, F ,NC4TO8("GRID"),NST,NC4TO8("LNSP"),1,                                                                      
     +                                           IBUF,MAXX,OK)                                                                      
      IF(NSETS.EQ.0) WRITE(6,6035) IBUF                                                                                             
      IF(.NOT.OK) CALL                             XIT('GSAPL',-7)                                                                  
      CALL CMPLBL (0,IBUF,0,KBUF,OK)                                                                                                
      IF(.NOT.OK) CALL                             XIT('GSAPL',-8)                                                                  
                                                                                                                                    
C     * INTERPOLATE IN-PLACE FROM ETA TO PRESSURE.                                                                                  
                                                                                                                                    
      CALL EAPL  (F(N), NWDS,PRLOG,NPL, F(N),SIG,NSL ,F(1),RLUP,RLDN,                                                               
     1            A,B, NSL+1,FSIG,DFLNSIG,DLNSIG)                                                                                   
                                                                                                                                    
C     * WRITE THE PRESSURE LEVEL GRIDS ONTO FILE 3.                                                                                 
                                                                                                                                    
      IBUF(3)=NAME                                                                                                                  
      IBUF(8)=NPACK                                                                                                                 
      CALL PUTSET2 (3,F(N),LEVP,NPL,IBUF,MAXX)                                                                                      
      IF(NSETS.EQ.0) WRITE(6,6035) IBUF                                                                                             
      NSETS=NSETS+1                                                                                                                 
      GO TO 150                                                                                                                     
                                                                                                                                    
C     * E.O.F. ON INPUT.                                                                                                            
                                                                                                                                    
  908 CALL                                         XIT('GSAPL',-9)                                                                  
  909 CALL                                         XIT('GSAPL',-10)                                                                 
C---------------------------------------------------------------------                                                              
 5010 FORMAT(10X,I5,2E10.0,1X,A4,E10.0)                                         J4                                                  
 5020 FORMAT(16I5)                                                              J4                                                  
 6010 FORMAT(' RLUP,RLDN = ',2F6.2,', ICOORD=',1X,A4,                                                                               
     1       ', P.LID (PA)=',E10.3)                                                                                                 
 6030 FORMAT('0 GSAPL INTERPOLATED',I5,' SETS OF ',A4)                                                                              
 6035 FORMAT(' ',A4,I10,2X,A4,I10,4I6)                                                                                              
      END                                                                                                                           
