      PROGRAM GSAPLT                                                                                                                
C     PROGRAM GSAPLT (GSTEMP,       GSPHI,       GSRGASM,      GSLNSP,          J2                                                  
C    1                GPTEMP,       GPPHI,       INPUT,        OUTPUT,  )       J2                                                  
C    2         TAPE11=GSTEMP,TAPE12=GSPHI,TAPE13=GSRGASM,TAPE14=GSLNSP,                                                             
C    3         TAPE15=GPTEMP,TAPE16=GPPHI,TAPE5 =INPUT,  TAPE6 =OUTPUT)                                                             
C     -----------------------------------------------------------------         J2                                                  
C                                                                               J2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       J2                                                  
C     OCT  5/94 - J. KOSHYK (INTRODUCE COLUMN ARRAYS TEMPSC, PHISC INTO CALL                                                        
C                 TO EAPLT).                                                                                                        
C     SEP 23/94 - J. KOSHYK (CORRECT TEMP/PHI REFERENCES IN PUTSET2 CALLS)                                                          
C     JUL 26/94 - J. KOSHYK                                                                                                         
C                                                                               J2                                                  
CGSAPLT  - INTERPOLATES TEMP AND PHI FROM ETA (SIGMA/HYBRID) LEVELS             J1                                                  
C          TO PRESSURE LEVELS.                                          4  2 C  J1                                                  
C                                                                               J3                                                  
CAUTHOR  - J. KOSHYK                                                            J3                                                  
C                                                                               J3                                                  
CPURPOSE - INTERPOLATES TEMP AND PHI FROM ETA (SIGMA/HYBRID) LEVELS             J3                                                  
C          TO PRESSURE LEVELS.  EXTRAPOLATION UP AND DOWN IS BY LAPSE RATES,    J3                                                  
C          DF/D(LN THETA) SPECIFIED BY THE USER.                                J3                                                  
C                                                                               J3                                                  
CINPUT FILES...                                                                 J3                                                  
C                                                                               J3                                                  
C      GSTEMP  = SERIES OF GRIDS OF TEMPERATURE ON ETA LEVELS.                  J3                                                  
C      GSPHI   = SERIES OF GRIDS OF PHI ON ETA LEVELS.                          J3                                                  
C      GSRGASM = SERIES OF GRIDS OF MOIST GAS CONSTANT ON ETA LEVELS.           J3                                                  
C      GSLNSP  = SERIES OF GRIDS OF LN(SF PRES).                                J3                                                  
C                                                                               J3                                                  
COUTPUT FILES...                                                                J3                                                  
C                                                                               J3                                                  
C      GPTEMP  = PRESSURE LEVEL TEMPERATURES.                                   J3                                                  
C      GPPHI   = PRESSURE LEVEL GEOPOTENTIALS.                                  J3                                                  
C                                                                                                                                   
CINPUT PARAMETERS...                                                            J5                                                  
C                                                                               J5                                                  
C      NPL    = NUMBER OF REQUESTED PRESSURE LEVELS, (MAX $L$).                 J5                                                  
C      RLUP   = LAPSE RATE, -DT/DZ USED TO EXTRAPOLATE UPWARDS (DEG/M).         J5                                                  
C      RLDN   = LAPSE RATE USED TO EXTRAPOLATE DOWNWARDS.                       J5                                                  
C      ICOORD = 4H SIG/4H ETA/4HET10/4HET15 FOR INPUT VERTICAL COORDINATE.      J5                                                  
C      PTOIT  = PRESSURE (PA) AT THE LID OF MODEL.                              J5                                                  
C      PR     = PRESSURE LEVELS (MB) (MONOTONE INCREASING I.E. TOP OF           J5                                                  
C               ATMOSPHERE TO BOTTOM.                                           J5                                                  
C                                                                               J5                                                  
CEXAMPLE OF INPUT CARDS...                                                      J5                                                  
C                                                                               J5                                                  
C*GSAPLT.     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 PR(100)                                                                                                                  
      REAL TEMP(1871328),PHI(1871328),RGASM(1871328),LNSP(18528)                                                                    
                                                                                                                                    
C     * WORKSPACE ARRAYS                                                                                                            
                                                                                                                                    
      REAL TEMPSC(100),PHISC(100),TPRESS(100),TRMEAN(101),                                                                          
     1     TGAMMA(101),TCHI(101)                                                                                                    
                                                                                                                                    
      COMMON/ICOM/IBUF(8),IDAT(18528)                                                                                               
                                                                                                                                    
      DATA MAXX/18528/, MAXL/1871328/, MAXLEV/100/                                                                                  
C---------------------------------------------------------------------------------                                                  
      NFIL=8                                                                                                                        
      CALL JCLPNT(NFIL,11,12,13,14,15,16,5,6)                                                                                       
      DO 110 N=11,16                                                                                                                
  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('GSAPLT',-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('GSAPLT',-2)                                                                 
                                                                                                                                    
      DO 115 L=1,NPL                                                                                                                
  115 PR(L)=100.E0*PR(L)                                                                                                            
                                                                                                                                    
C     * GET ETA VALUES FROM THE GSTEMP FILE.                                                                                        
                                                                                                                                    
      CALL FILEV (LEV,NSL,IBUF,11)                                                                                                  
      IF(NSL.LT.1 .OR. NSL.GT.MAXLEV) CALL         XIT('GSAPLT',-3)                                                                 
      NWDS = IBUF(5)*IBUF(6)                                                                                                        
      IF((MAX(NSL,NPL)+1)*NWDS.GT.MAXL) CALL       XIT('GSAPLT',-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 MULTI-LEVEL TEMPERATURE FIELD FROM FILE GSTEMP.                                                                         
                                                                                                                                    
      NSETS=0                                                                                                                       
  150 CALL GETSET2 (11,TEMP,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('GSAPLT',-5)                                                                 
        ELSE                                                                                                                        
          CALL                                     XIT('GSAPLT', 0)                                                                 
        ENDIF                                                                                                                       
      ENDIF                                                                                                                         
      CALL CMPLBL (0,IBUF,0,KBUF,OK)                                                                                                
      IF(.NOT.OK) CALL                             XIT('GSAPLT',-6)                                                                 
      NPACK=IBUF(8)                                                                                                                 
                                                                                                                                    
C     * GET MULTI-LEVEL GEOPOTENTIAL FIELD FROM FILE GSPHI.                                                                         
                                                                                                                                    
      CALL GETSET2 (12,PHI,LEV,NSL,IBUF,MAXX,OK)                                                                                    
      IF(NSETS.EQ.0) WRITE(6,6035) IBUF                                                                                             
      IF(.NOT.OK) CALL                             XIT('GSAPLT',-7)                                                                 
      CALL CMPLBL (0,IBUF,0,KBUF,OK)                                                                                                
      IF(.NOT.OK) CALL                             XIT('GSAPLT',-8)                                                                 
                                                                                                                                    
C     * GET MULTI-LEVEL MOIST GAS CONSTANT FIELD FROM FILE GSRGASM.                                                                 
                                                                                                                                    
      CALL GETSET2 (13,RGASM,LEV,NSL,IBUF,MAXX,OK)                                                                                  
      IF(NSETS.EQ.0) WRITE(6,6035) IBUF                                                                                             
      IF(.NOT.OK) CALL                             XIT('GSAPLT',-9)                                                                 
      CALL CMPLBL (0,IBUF,0,KBUF,OK)                                                                                                
      IF(.NOT.OK) CALL                             XIT('GSAPLT',-10)                                                                
                                                                                                                                    
C     * GET LN(SF PRES).                                                                                                            
                                                                                                                                    
      NST= IBUF(2)                                                                                                                  
      CALL GETFLD2 (14,LNSP,NC4TO8("GRID"),NST,NC4TO8("LNSP"),1,                                                                    
     +                                             IBUF,MAXX,OK)                                                                    
      IF(NSETS.EQ.0) WRITE(6,6035) IBUF                                                                                             
      IF(.NOT.OK) CALL                             XIT('GSAPLT',-11)                                                                
      CALL CMPLBL (0,IBUF,0,KBUF,OK)                                                                                                
      IF(.NOT.OK) CALL                             XIT('GSAPLT',-12)                                                                
                                                                                                                                    
C     * INTERPOLATE IN-PLACE FROM ETA TO PRESSURE.                                                                                  
                                                                                                                                    
      CALL EAPLT  (TEMP,PHI,RGASM,LNSP,NWDS,NSL,NSL+1,PR,                                                                           
     1             NPL,RLUP,RLDN,A,B,TEMP,PHI,                                                                                      
     2             TEMPSC,PHISC,TPRESS,TRMEAN,TGAMMA,TCHI)                                                                          
                                                                                                                                    
C     * WRITE THE PRESSURE LEVEL GRIDS ONTO FILES 15 AND 16.                                                                        
                                                                                                                                    
      IBUF(8)=NPACK                                                                                                                 
                                                                                                                                    
      IBUF(3)=NC4TO8("TEMP")                                                                                                        
      CALL PUTSET2 (15,TEMP,LEVP,NPL,IBUF,MAXX)                                                                                     
      IF(NSETS.EQ.0) WRITE(6,6035) IBUF                                                                                             
                                                                                                                                    
      IBUF(3)=NC4TO8(" PHI")                                                                                                        
      CALL PUTSET2 (16, PHI,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('GSAPLT',-13)                                                                
  909 CALL                                         XIT('GSAPLT',-14)                                                                
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 GSAPLT INTERPOLATED',I5,' SETS OF ',A4)                                                                             
 6035 FORMAT(' ',A4,I10,2X,A4,I10,4I6)                                                                                              
      END                                                                                                                           
