      PROGRAM ATMABSO                                                                                                               
C     PROGRAM ATMABSO (SFPR,       HRS,       ABS,       OUTPUT,        )       D2                                                  
C    1           TAPE1=SFPR, TAPE2=HRS, TAPE3=ABS, TAPE6=OUTPUT)                                                                    
C     ----------------------------------------------------------                D2                                                  
C                                                                               D2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       D2                                                  
C     JAN 07/93 - E.CHAN. (DECODE IBUF(4) FOR LEVEL INFORMATION).                                                                   
C     JAN 29/92 - E. CHAN (CONVERT HOLLERITH LITERALS TO ASCII)                                                                     
C     MAY 06/83 - R.LAPRISE.                                                                                                        
C     OCT 21/81 - J.P.BLANCHET                                                                                                      
C                                                                               D2                                                  
CATMABSO - COMPUTES THE FLUX ABSORBED/EMITTED BY THE ATMOSPHERE         2  1    D1                                                  
C                                                                               D3                                                  
CAUTHOR  - J.P.BLANCHET                                                         D3                                                  
C                                                                               D3                                                  
CPURPOSE - THIS PROGRAM COMPUTES THE FLUX ABSORBED (OR EMITTED FOR IR)          D3                                                  
C          BY THE ATMOSPHERE.                                                   D3                                                  
C          NOTE -  MKS UNITS ARE ASSUMED.                                       D3                                                  
C                                                                               D3                                                  
CINPUT FILES...                                                                 D3                                                  
C                                                                               D3                                                  
C      SFPR = SURFACE PRESSURE IN MB.                                           D3                                                  
C      HRS  = HEATING RATES AT EACH LEVELS IN DEG K SEC-1.                      D3                                                  
C                                                                               D3                                                  
COUTPUT FILE...                                                                 D3                                                  
C                                                                               D3                                                  
C      ABS  = ENERGY ABSORBED (EMITTED) BY THE ATMOSPHERE W/M                   D3                                                  
C----------------------------------------------------------------------------                                                       
C                                                                                                                                   
C     * NOTE - THE FOLLOWING DATA ARE READ                                                                                          
C     *            ILEV = NUMBER OF MODEL LEVELS.                                                                                   
C     *            S    = POSITION OF LEVELS IN SIGMA COORDINATES.                                                                  
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      LOGICAL OK                                                                                                                    
C                                                                                                                                   
      INTEGER LHALF(100)                                                                                                            
C                                                                                                                                   
      REAL SH(100),S(100),DS(100)                                                                                                   
C                                                                                                                                   
C                                                                                                                                   
      COMMON/BLANCK/ F(18528),G(18528),H(18528)                                                                                     
      COMMON /ICOM/ IBUF(8),IDAT(18528)                                                                                             
      COMMON /JCOM/ JBUF(8),JDAT(18528)                                                                                             
C                                                                                                                                   
      DATA MAXX/18528/,MAXL/100/                                                                                                    
      DATA CP/1004.64E0/,GRAV/9.80616E0/,PAMB/100.E0/                                                                               
C-----------------------------------------------------------------------                                                            
      NFF=4                                                                                                                         
      CALL JCLPNT(NFF,1,2,3,6)                                                                                                      
      REWIND 1                                                                                                                      
      REWIND 2                                                                                                                      
      REWIND 3                                                                                                                      
C                                                                                                                                   
      CALL FILEV(LHALF,ILEV,IBUF,2)                                                                                                 
      IF((ILEV.LT.2).OR.(ILEV.GT.MAXL))CALL        XIT('ATMABSO',-1)                                                                
C                                                                                                                                   
C     * DECODE LEVELS.                                                                                                              
C                                                                                                                                   
      CALL LVDCODE(SH,LHALF,ILEV)                                                                                                   
C                                                                                                                                   
      DO 2 I=1,ILEV                                                                                                                 
    2 SH(I) = SH(I) * 0.001E0                                                                                                       
C                                                                                                                                   
      ILEVM=ILEV-1                                                                                                                  
      S(ILEV)=SH(ILEV)**2.E0                                                                                                        
      DO 3 I=1,ILEVM                                                                                                                
      L=ILEV-I                                                                                                                      
    3 S(L)=SH(L)**2.E0/S(L+1)                                                                                                       
C                                                                                                                                   
      WRITE(6,6001) ILEV                                                                                                            
      WRITE(6,6002) (S(I),I=1,ILEV)                                                                                                 
      WRITE(6,6003) (SH(I),I=1,ILEV)                                                                                                
C                                                                                                                                   
      DO 5 L=1,ILEVM                                                                                                                
    5 DS(L)=S(L+1)-S(L)                                                                                                             
      DS(ILEV)=1.E0-S(ILEV)                                                                                                         
C                                                                                                                                   
      ICOUNT=0                                                                                                                      
      CST=CP*PAMB/GRAV                                                                                                              
C                                                                                                                                   
  200 CONTINUE                                                                                                                      
C                                                                                                                                   
C     *** BRING IN SURFACE PRESSURE.                                                                                                
C                                                                                                                                   
      CALL GETFLD2(1,F,NC4TO8("GRID"),-1,NC4TO8("NEXT"),1,IBUF,MAXX,OK)                                                             
      IF(ICOUNT.EQ.0)THEN                                                                                                           
        IF(.NOT.OK) CALL                           XIT('ATMABSO',-2)                                                                
        WRITE(6,6025) IBUF                                                                                                          
      ENDIF                                                                                                                         
C                                                                                                                                   
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6000) ICOUNT,IBUF                                                                                                   
        CALL                                       XIT('ATMABSO',0)                                                                 
      ENDIF                                                                                                                         
C                                                                                                                                   
      NSIZE=IBUF(5)*IBUF(6)                                                                                                         
C                                                                                                                                   
      DO 20 I=1,NSIZE                                                                                                               
   20 H(I)=0.E0                                                                                                                     
C                                                                                                                                   
C     *** BRING IN HEATING RATES (HRS).                                                                                             
C                                                                                                                                   
      DO 40 L=1,ILEV                                                                                                                
      CALL GETFLD2(2,G,NC4TO8("GRID"),-1,NC4TO8("NEXT"),LHALF(L),                                                                   
     +                                              JBUF,MAXX,OK)                                                                   
      IF(.NOT.OK)  CALL                            XIT('ATMABSO',-3)                                                                
      IF(ICOUNT.EQ.0) WRITE(6,6025) JBUF                                                                                            
C                                                                                                                                   
      IF(IBUF(2).NE.JBUF(2).OR.IBUF(5).NE.JBUF(5).OR.IBUF(6).NE.JBUF(6))                                                            
     1    CALL                                     XIT('ATMABSO',-4)                                                                
C                                                                                                                                   
C     *** INTEGRATE (HEATING RATE)*DSIGMA  ON ALL LEVELS.                                                                           
C                                                                                                                                   
      DO 30 I=1,NSIZE                                                                                                               
   30 H(I)=H(I)+G(I)*DS(L)                                                                                                          
C                                                                                                                                   
   40 CONTINUE                                                                                                                      
C                                                                                                                                   
C     *** CHANGE IN PRESSURE UNITS.                                                                                                 
C                                                                                                                                   
      DO 50 I=1,NSIZE                                                                                                               
   50 H(I)=H(I)*F(I)*CST                                                                                                            
C                                                                                                                                   
C     *** PLACE DATA IN FILE "ABS"                                                                                                  
C                                                                                                                                   
      IBUF(3)=NC4TO8("ABSO")                                                                                                        
C                                                                                                                                   
      CALL PUTFLD2(3,H,IBUF,MAXX)                                                                                                   
      IF(ICOUNT.EQ.0) WRITE(6,6025) IBUF                                                                                            
C                                                                                                                                   
      ICOUNT=ICOUNT+1                                                                                                               
      GO TO 200                                                                                                                     
C-----------------------------------------------------------------------                                                            
 6000 FORMAT(/,/,5X,'NUMBER OF RECORDS IN AND OUT = ',I6,//,5X,A4,                                                                  
     1           I10,2A4,I10,4I6,//)                                                                                                
 6001 FORMAT(//,5X,'ILEV =',I3,//)                                                                                                  
 6002 FORMAT(5X,'S =',15F8.5/(8X,15F8.5/))                                                                                          
 6003 FORMAT(5X,'SH=',15F8.5/(8X,15F8.5/))                                                                                          
 6025 FORMAT(' ',A4,I10,2X,A4,I10,4I6)                                                                                              
      END                                                                                                                           
