      PROGRAM INCHEM3                                                                                                               
C     PROGRAM INCHEM3 (ICTL,        MASK,       LLPHYS,       LLCHEM,           I2                                                  
C    1                                          GGCHEM,        OUTPUT,  )       I2                                                  
C    2          TAPE99=ICTL, TAPE88=MASK, TAPE77=LLPHYS,TAPE1=LLCHEM,                                                               
C    3                                    TAPE2=GGCHEM,  TAPE6=OUTPUT)                                                              
C     ----------------------------------------------------------------          I2                                                  
C                                                                               I2                                                  
C     JUN 18/08 - M. LAZARE. - USE "-1" FOR IBUF(1-4) IN READING "MASK" RECORDS.I2                                                  
C                            - USE IOPTION=0 EXCEPT FOR DMSO AND VOLCANIC       I2                                                  
C                              HEIGHTS TO MAINTAIN GLOBAL AVERAGE.              I2                                                  
C     FEB 02/08 - M. LAZARE. - INCREASE TO HIGHER RESOLUTION AND REMOVE                                                             
C                              UNUSED {EVOL,HVOL,ESO2,EBC,EOC,EOCF}                                                                 
C                            - CALLS NEW HRTOLR4, REMOVING IGRID AND                                                                
C                              PASSING IN ADDED WORK ARRAYS: LONM,LONP,                                                             
C                              LATM, LATP, TO CORRECT AREA-AVERAGING AROUND                                                         
C                              EDGES OF LOW-RES GRID SQUARE.                                                                        
C     JAN 29/07 - X.MA, M.LAZARE. PREVOUS VERSION INCHEM2.                                                                          
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)                                                           
C     JUN  6/2000 - M.LAZARE.  NEW PROGRAM BASED ON GRID PHYSICS                                                                    
C                              INITIALIZATION, EXCEPT DEDICATED TO                                                                  
C                              CHEMISTRY INPUT FIELDS (SUCH AS SULFUR                                                               
C                              CYCLE.                                                                                               
C                                                                               I2                                                  
CINCHEM3 - GRID CHEMISTRY INITIALIZATION PROGRAM FOR GCM15G+            2  1    I1                                                  
C                                                                               I3                                                  
CAUTHOR  - M.LAZARE                                                             I3                                                  
C                                                                               I3                                                  
CPURPOSE - CONVERTS HIGH-RESOLUTION LAT-LONG SURFACE CHEMISTRY GRIDS TO         I3                                                  
C          GAUSSIAN GRIDS.                                                      I3                                                  
C          NOTE - ALL INITIAL SURFACE FIELDS ARE .GE. 1X1 DEGREE OFFSET         I3                                                  
C                 RESOLUTION, UPT TO 1/12 X 1/12. THEY ARE AREA-AVERAGED        I3                                                  
C                 USING THE SUBROUTINE HRTOLR5.                                 I3                                                  
C                                                                               I3                                                  
CINPUT FILES...                                                                 I3                                                  
C                                                                               I3                                                  
C      ICTL   = CONTAINS GLOBAL LAT-LONG GRIDS WHICH ARE READ AND               I3                                                  
C               HORIZONTALLY SMOOTHED TO GLOBAL GAUSSIAN GRIDS. THE LAT-        I3                                                  
C               LONG GRIDS MAY BE IN ANY ORDER ON THIS FILE.                    I3                                                  
C                                                                               I3                                                  
C      MASK   = CONTAINS LAND MASK (NO SEA-ICE, I.E. -1/0) ON MODEL             I3                                                  
C               GAUSSIAN-GRID.                                                  I3                                                  
C                                                                               I3                                                  
C      LLPHYS = OFFSET LAT-LONG PHYSICS GRIDS(USED ONLY TO GET MASK)            I3                                                  
C                                                                               I3                                                  
C      LLCHEM_AEROCOM = CONTAINS THE HIGH-RES CHEMISTRY EMISSION GRIDS:         I3                                                  
C                                                                               I3                                                  
C      NAME            VARIABLE                   UNITS                         I3                                                  
C      ----            --------                   -----                         I3                                                  
C                                                                               I3                                                  
C      DMSO   KETTLE OCEANIC DMS CONCENTRATIONS NANOMOL/LITRE                   I3                                                  
C      EDMS   LAND DMS FLUXES                   KG/M2-S                         I3                                                  
C                                                                               I3                                                  
C      NAME            VARIABLE                   UNITS                         I3                                                  
C      ----            --------                   -----                         I3                                                  
C                                                                               I3                                                  
C      EBWA   FOREST FIRE BC (1997-2002 mean)   KG/M2-S                         I3                                                  
C      EOWA   FOREST FIRE POM (1997-2002 mean)  KG/M2-S                         I3                                                  
C      ESWA   FOREST FIRE SO2 (1997-2002 mean)  KG/M2-S                         I3                                                  
C      EBBT   BIOFUEL BC EMISSIONS (2000)       KG/M2-S                         I3                                                  
C      EOBT   BIOFUEL POM EMISSIONS (2000)      KG/M2-S                         I3                                                  
C      EBFT   FOSSIL FUEL BC EMISSIONS (2000)   KG/M2-S                         I3                                                  
C      EOFT   FOSSIL FUEL POM EMISSIONS (2000)  KG/M2-S                         I3                                                  
C      ESDT   SO2 EMISSIONS - DOMESTIC (2000)   KG/M2-S                         I3                                                  
C      ESIT   SO2 EMISSIONS - INDUSTRIAL (2000) KG/M2-S                         I3                                                  
C      ESST   SO2 EMISSIONS - SHIPPING (2000)   KG/M2-S                         I3                                                  
C      ESOT   SO2 EMISSIONS - OFF-ROAD (2000)   KG/M2-S                         I3                                                  
C      ESPT   SO2 EMISSIONS - POWERPLANTS (2000)KG/M2-S                         I3                                                  
C      ESRT   SO2 EMISSIONS - ROADS (2000)      KG/M2-S                         I3                                                  
C      EOST   SECONDARY ORGANIC AEROSOLS        KG/M2-S                         I3                                                  
C      ESCV   SO2 FROM CONTINUOUS VOLCANOES     KG/M2-S                         I3                                                  
C      EHCV   HEIGHT OF CONTINUOUS VOLCANOES    M                               I3                                                  
C      ESEV   SO2 FROM EXPLOSIVE VOLCANOES      KG/M2-S                         I3                                                  
C      EHEV   HEIGHT OF EXPLOSIVE VOLCANOES     M                               I3                                                  
C                                                                               I3                                                  
COUTPUT FILE...                                                                 I3                                                  
C                                                                               I3                                                  
C      GGCHEM = GAUSSIAN GRID SURFACE PHYSICS FIELDS:                           I3                                                  
C                                                                               I3                                                  
C      NAME            VARIABLE                   UNITS                         I3                                                  
C      ----            --------                   -----                         I3                                                  
C                                                                               I3                                                  
C      DMSO   KETTLE OCEANIC DMS CONCENTRATIONS NANOMOL/LITRE                   I3                                                  
C      EDMS   LAND DMS FLUXES                   KG/M2-S                         I3                                                  
C                                                                               I3                                                  
C      GGCHEM = GAUSSIAN GRID SURFACE PHYSICS FIELDS:                           I3                                                  
C                                                                               I3                                                  
C      NAME            VARIABLE                   UNITS                         I3                                                  
C      ----            --------                   -----                         I3                                                  
C                                                                               I3                                                  
C      EBWA   FOREST FIRE BC (1997-2002 mean)   KG/M2-S                         I3                                                  
C      EOWA   FOREST FIRE POM (1997-2002 mean)  KG/M2-S                         I3                                                  
C      ESWA   FOREST FIRE SO2 (1997-2002 mean)  KG/M2-S                         I3                                                  
C      EBBT   BIOFUEL BC EMISSIONS (2000)       KG/M2-S                         I3                                                  
C      EOBT   BIOFUEL POM EMISSIONS (2000)      KG/M2-S                         I3                                                  
C      EBFT   FOSSIL FUEL BC EMISSIONS (2000)   KG/M2-S                         I3                                                  
C      EOFT   FOSSIL FUEL POM EMISSIONS (2000)  KG/M2-S                         I3                                                  
C      ESDT   SO2 EMISSIONS - DOMESTIC (2000)   KG/M2-S                         I3                                                  
C      ESIT   SO2 EMISSIONS - INDUSTRIAL (2000) KG/M2-S                         I3                                                  
C      ESST   SO2 EMISSIONS - SHIPPING (2000)   KG/M2-S                         I3                                                  
C      ESOT   SO2 EMISSIONS - OFF-ROAD (2000)   KG/M2-S                         I3                                                  
C      ESPT   SO2 EMISSIONS - POWERPLANTS (2000)KG/M2-S                         I3                                                  
C      ESRT   SO2 EMISSIONS - ROADS (2000)      KG/M2-S                         I3                                                  
C      EOST   SECONDARY ORGANIC AEROSOLS        KG/M2-S                         I3                                                  
C      ESCV   SO2 FROM CONTINUOUS VOLCANOES     KG/M2-S                         I3                                                  
C      EHCV   HEIGHT OF CONTINUOUS VOLCANOES    M                               I3                                                  
C      ESEV   SO2 FROM EXPLOSIVE VOLCANOES      KG/M2-S                         I3                                                  
C      EHEV   HEIGHT OF EXPLOSIVE VOLCANOES     M                               I3                                                  
C-----------------------------------------------------------------------------                                                      
C     * IF NO HIGH-RESOLUTION POINTS ARE FOUND WITHIN A PARTICULAR LOW-                                                             
C     * RESOLUTION GRID SQUARE, EVEN AFTER CONSIDERING INFORMATION FROM                                                             
C     * NEAREST-NEIGHBOUR POINTS ON THE GAUSSIAN GRID, AN ABORT CONDITION                                                           
C     * IS GENERATED.                                                                                                               
                                                                                                                                    
C     * HRMASK IS THE HIGH-RESOLUTION OFFSET LAND MASK (LAND=-1., ELSE 0.)                                                          
C     * WHILE MASK IS THE STANDARD LAND MASK AT GAUSSIAN GRID RESOLUTION                                                            
C     * (READ IN).                                                                                                                  
                                                                                                                                    
C     * GH IS GENERALLY THE RESULTING OUTPUT FIELD ARRAY FOR ALL FIELDS.                                                            
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      PARAMETER (NLGX=360*12,NLATX=180*12,IGND=3,NM=12,NM1=NM+1,                                                                    
     1           NLOMAX=64980,NHIMAX=NLGX*NLATX,IJB=NHIMAX,NLEV=6)                                                                  
C                                                                                                                                   
      REAL GLL(NHIMAX),HRMASK(NHIMAX)                                                                                               
      REAL GG(NLOMAX),  GH(NLOMAX),  MASK(NLOMAX), MASKTMP(NLOMAX)                                                                  
      REAL DLAT(181), DLON(361)                                                                                                     
      REAL LONM(361), LONP(361), LATM(181), LATP(181)                                                                               
      REAL*8 SL(181), CL(181), WL(181), WOSSL(181), RAD(181)                                                                        
C                                                                                                                                   
      INTEGER NFDM(NM),MMD(NM), LEVC(NLEV)                                                                                          
                                                                                                                                    
      LOGICAL OK                                                                                                                    
                                                                                                                                    
C     * WORK ARRAYS FOR SUBROUTINE GGFILL CALLED IN HRTOLR4.                                                                        
                                                                                                                                    
      INTEGER LONB(NLOMAX), LATB(NLOMAX)                                                                                            
C                                                                                                                                   
C     * WORK ARRAYS FOR SUBROUTINE HRTOLR4.                                                                                         
C     * NOTE THAT THE SIZES OF ARRAYS VAL,DIST,LOCAT,IVAL,LOCFST AND                                                                
C     * NMAX REALLY REPRESENT THE NUMBER OF HIGH-RESOLUTION GRID                                                                    
C     * POINTS WITHIN A LOW-RESOLUTION GRID SQUARE. FOR CONVENIENCE                                                                 
C     * SAKE, THEY ARE DIMENSIONED WITH SIZE "NLG" AND AN ABORT                                                                     
C     * CONDITION IS GENERATED WITHIN THE SUBROUTINE.                                                                               
C                                                                                                                                   
      REAL GCHRTMP(NLGX,NLATX)                                                                                                      
      REAL RLON(NLGX), RLAT(NLATX)                                                                                                  
                                                                                                                                    
      REAL GCLRTMP(361,181)                                                                                                         
      INTEGER LATL(181), LATH(181), LONL(361), LONH(361)                                                                            
                                                                                                                                    
      REAL VAL(NLGX), DIST(NLGX)                                                                                                    
      INTEGER LOCAT(NLGX), IVAL(NLGX), LOCFST(NLGX), NMAX(NLGX)                                                                     
C                                                                                                                                   
      COMMON/ICOM/IBUF(8),IDAT(IJB)                                                                                                 
                                                                                                                                    
      DATA NFDM/1,32,60,91,121,152,182,213,244,274,305,335/                                                                         
      DATA  MMD/16,46,75,106,136,167,197,228,259,289,320,350/                                                                       
      DATA LEVC/ 100,500,1000,2000,3000,6000/                                                                                       
      DATA MAXX,NPGG/IJB,+1/                                                                                                        
C---------------------------------------------------------------------                                                              
      NFF=6                                                                                                                         
      CALL JCLPNT(NFF,99,88,77,1,2,6)                                                                                               
                                                                                                                                    
      INTERP=1                                                                                                                      
                                                                                                                                    
C     * READ DAY OF THE YEAR, GAUSSIAN GRID SIZE AND LAND SURFACE SCHEME                                                            
C     * CODE FROM CONTROL FILE.                                                                                                     
                                                                                                                                    
      REWIND 99                                                                                                                     
      READ(99,END=910) LABL                                                                                                         
      READ(99,END=911) LABL,IXX,IXX,ILG,ILAT,IXX,IDAY,IXX,IXX                                                                       
      ILG1  = ILG+1                                                                                                                 
      ILATH = ILAT/2                                                                                                                
      LGG   = ILG1*ILAT                                                                                                             
      WRITE(6,6010)  IDAY,ILG1,ILAT                                                                                                 
                                                                                                                                    
C     * GAUSSG COMPUTES THE VALUE OF THE GAUSSIAN LATITUDES AND THEIR                                                               
C     * SINES AND COSINES. TRIGL MAKES THEM GLOBAL (S TO N).                                                                        
                                                                                                                                    
      CALL GAUSSG(ILATH,SL,WL,CL,RAD,WOSSL)                                                                                         
      CALL  TRIGL(ILATH,SL,WL,CL,RAD,WOSSL)                                                                                         
                                                                                                                                    
      DO 100 I=1,ILAT                                                                                                               
          DLAT(I) = RAD(I)*180.E0/3.14159E0                                                                                         
  100 CONTINUE                                                                                                                      
                                                                                                                                    
C     * DEFINE LONGITUDE VECTOR FOR GAUSSIAN GRID.                                                                                  
                                                                                                                                    
      DGX=360.E0/(FLOAT(ILG))                                                                                                       
      DO 120 I=1,ILG1                                                                                                               
          DLON(I)=DGX*FLOAT(I-1)                                                                                                    
  120 CONTINUE                                                                                                                      
                                                                                                                                    
      NMO=12                                                                                                                        
C                                                                                                                                   
C     * READ-IN THE STANDARD LAND MASK ON THE MODEL GAUSSIAN GRID.                                                                  
C     * IN CASE IT CONTAINS INFORMATION ON LAKES (GC=+2) AND IS PACKED,                                                             
C     * PROCESS THE FIELD TO GET ONLY VALUES OF (-1/0) FOR (LAND/NOLAND)                                                            
C     * BEFORE PROCESSING FURTHER.                                                                                                  
C     * CREATE A FIELD "MASKTMP" WHICH EXCLUDES ANTARCTICA, TO BE                                                                   
C     * CONSISTENT WITH HIGH-RES GCL2000 DATA FOR PROCESSING VIA HRTOLR4.                                                           
C     * SUBSEQUENTLY, FOR EACH FIELD, ANTARCTICA IS PUT BACK IN WITH                                                                
C     * ASSIGNED VALUES REPRESENTATIVE OF EACH FIELD.                                                                               
C                                                                                                                                   
      NDAY=0                                                                                                                        
C     CALL GETFLD2(88,MASK,NC4TO8("GRID"),NDAY,NC4TO8("MASK"),                                                                      
C    +                                         1,IBUF,MAXX,OK)                                                                      
      CALL GETFLD2(88,MASK,-1,-1,-1,-1,IBUF,MAXX,OK)                                                                                
      IF(.NOT.OK) CALL                             XIT('INCHEM3',-1)                                                                
      IF(IBUF(5).NE.ILG1.OR.IBUF(6).NE.ILAT) CALL  XIT('INCHEM3',-2)                                                                
      WRITE(6,6025) IBUF                                                                                                            
C                                                                                                                                   
      DO 125 I=1,LGG                                                                                                                
          IVALM=NINT(MASK(I))                                                                                                       
          MASK(I)=REAL(IVALM)                                                                                                       
  125 CONTINUE                                                                                                                      
C                                                                                                                                   
      DO 126 I=1,LGG                                                                                                                
          MASK(I)=MIN(0.E0, MASK(I))                                                                                                
          J=(I-1)/ILG1+1                                                                                                            
          IF(DLAT(J).GT.-62.0) THEN                                                                                                 
            MASKTMP(I)=MASK(I)                                                                                                      
          ELSE                                                                                                                      
            IGLAC=I                                                                                                                 
            MASKTMP(I)=0.                                                                                                           
          ENDIF                                                                                                                     
  126 CONTINUE                                                                                                                      
C                                                                                                                                   
C     * SAVE HIGH-RES LAND MASK (-1./0.) INTO ARRAY "HRMASK", FOR USE                                                               
C     * IN PROCESSING SUBSEQUENT FIELDS.                                                                                            
C                                                                                                                                   
      CALL GETFLD2(-77,HRMASK,NC4TO8("GRID"),NDAY,NC4TO8("  GC"),                                                                   
     +                                            1,IBUF,MAXX,OK)                                                                   
      IF(.NOT.OK) CALL                             XIT('INCHEM3',-3)                                                                
      WRITE(6,6025) IBUF                                                                                                            
      NLG=IBUF(5)                                                                                                                   
      NLAT=IBUF(6)                                                                                                                  
      LLL=NLG*NLAT                                                                                                                  
C================================================================= OLD EMISSIONS                                                    
C     * FIELDS FOR EACH OF TWELVE MID-MONTHS:                                                                                       
C                                                                                                                                   
C     * LOOP OVER MONTHS.                                                                                                           
C                                                                                                                                   
C---------------------------------------------------------------------                                                              
      DO 180 N=1,NMO                                                                                                                
        NDAY=MMD(N)                                                                                                                 
C                                                                                                                                   
C       * GET OCEANIC DMS CONCENTRATIONS AND AREA-AVERAGE TO GAUSSIAN GRID.                                                         
C       * ENSURE DMS=0. OVER LAND AT HIGH RESOLUTION,                                                                               
                                                                                                                                    
        CALL GETFLD2(-1,GLL,NC4TO8("GRID"),MMD(N),NC4TO8("DMSO"),1,                                                                 
     +                                                IBUF,MAXX,OK)                                                                 
        IF(.NOT.OK) CALL                           XIT('INCHEM3',-4)                                                                
        IF(IBUF(5).NE.NLG.OR.IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-5)                                                                
        WRITE(6,6025) IBUF                                                                                                          
C                                                                                                                                   
        DO 150 I=1,LLL                                                                                                              
          GLL(I)=MAX(GLL(I),0.E0)                                                                                                   
          IF(HRMASK(I).EQ.-1.E0) GLL(I)=0.E0                                                                                        
  150   CONTINUE                                                                                                                    
C                                                                                                                                   
        IOPTION=1                                                                                                                   
        ICHOICE=1                                                                                                                   
        CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                            
     1               LONM,LONP,LATM,LATP,                                                                                           
     2               GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                           
     3               OK,LONBAD,LATBAD,                                                                                              
     4               GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                 
     5               VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                     
C                                                                                                                                   
        IF(.NOT.OK)THEN                                                                                                             
          WRITE(6,6030) LONBAD,LATBAD                                                                                               
          CALL                                     XIT('INCHEM3',-6)                                                                
        ENDIF                                                                                                                       
C                                                                                                                                   
C       * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                           
C                                                                                                                                   
        DO 160 I=1,LGG                                                                                                              
          IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                          
  160   CONTINUE                                                                                                                    
C                                                                                                                                   
        CALL SETLAB(IBUF,NC4TO8("GRID"),NDAY,NC4TO8("DMSO"),1,                                                                      
     +                                       ILG1,ILAT,0,NPGG)                                                                      
        CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                
        WRITE(6,6026) IBUF                                                                                                          
  180 CONTINUE                                                                                                                      
C------------------------------------------------------------------------                                                           
      DO 210 N=1,NMO                                                                                                                
        NDAY=MMD(N)                                                                                                                 
C                                                                                                                                   
C       * GET LAND DMS FLUXES AND AREA-AVERAGE TO GAUSSIAN GRID.                                                                    
C       * ENSURE DMS=0. OVER NON-LAND AT HIGH RESOLUTION,                                                                           
                                                                                                                                    
        CALL GETFLD2(-1,GLL,NC4TO8("GRID"),MMD(N),NC4TO8("EDMS"),1,                                                                 
     +                                                IBUF,MAXX,OK)                                                                 
        IF(.NOT.OK) CALL                           XIT('INCHEM3',-7)                                                                
        IF(IBUF(5).NE.NLG.OR.IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-8)                                                                
        WRITE(6,6025) IBUF                                                                                                          
C                                                                                                                                   
        DO 190 I=1,LLL                                                                                                              
          GLL(I)=MAX(GLL(I),0.E0)                                                                                                   
          IF(HRMASK(I).EQ.0.E0) GLL(I)=0.E0                                                                                         
  190   CONTINUE                                                                                                                    
C                                                                                                                                   
        IOPTION=0                                                                                                                   
        ICHOICE=1                                                                                                                   
        CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                            
     1               LONM,LONP,LATM,LATP,                                                                                           
     2               GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                           
     3               OK,LONBAD,LATBAD,                                                                                              
     4               GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                 
     5               VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                     
C                                                                                                                                   
        IF(.NOT.OK)THEN                                                                                                             
          WRITE(6,6030) LONBAD,LATBAD                                                                                               
          CALL                                     XIT('INCHEM3',-9)                                                                
        ENDIF                                                                                                                       
C                                                                                                                                   
C       * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                           
C                                                                                                                                   
        DO 200 I=1,LGG                                                                                                              
          IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                          
  200   CONTINUE                                                                                                                    
C                                                                                                                                   
        CALL SETLAB(IBUF,NC4TO8("GRID"),NDAY,NC4TO8("EDMS"),1,                                                                      
     +                                       ILG1,ILAT,0,NPGG)                                                                      
        CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                
        WRITE(6,6026) IBUF                                                                                                          
C------------------------------------------------------------------------                                                           
  210 CONTINUE                                                                                                                      
C=====================================================================                                                              
C     * GET MODEL SURFACE GEOPOTENTIAL FROM THE CONTROL FILE                                                                        
C     * (GENERATED IN ICNTRLC). THIS IS USED LATER WITH VOLCANOES                                                                   
C     * TO ESTABLISH HEIGHTS ABOVE GROUND.                                                                                          
C                                                                                                                                   
      CALL GETFLD2(99,GG,NC4TO8("GRID"),-1,NC4TO8("PHIM"),1,                                                                        
     1             IBUF,MAXX,OK)                                                                                                    
      IF(.NOT.OK) CALL                             XIT('INCHEM3',-10)                                                               
        IF(IBUF(5).NE.ILG1.OR.IBUF(6).NE.ILAT)CALL XIT('INCHEM3',-11)                                                               
      CALL PRTLAB (IBUF)                                                                                                            
C================================================================= NEW EMISSIONS                                                    
C     * FIELDS FOR EACH OF TWELVE MID-MONTHS:                                                                                       
C                                                                                                                                   
C     * LOOP OVER MONTHS.                                                                                                           
C                                                                                                                                   
      DO 261 N=1,NMO                                                                                                                
      DO 260 K=1,NLEV                                                                                                               
        NDAY=MMD(N)                                                                                                                 
C---------------------------------------------------------------------                                                              
C       * GET GFED BC EMISSIONS AND AREA-AVERAGE TO GAUSSIAN GRID.                                                                  
                                                                                                                                    
        CALL GETFLD2(-1,GLL,NC4TO8("GRID"),MMD(N),NC4TO8("EBWA"),                                                                   
     +                                        LEVC(K),IBUF,MAXX,OK)                                                                 
        IF(.NOT.OK) CALL                           XIT('INCHEM3',-12)                                                               
        IF(IBUF(5).NE.NLG.OR.IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-13)                                                               
        WRITE(6,6025) IBUF                                                                                                          
C                                                                                                                                   
        IOPTION=0                                                                                                                   
        ICHOICE=1                                                                                                                   
        CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                            
     1               LONM,LONP,LATM,LATP,                                                                                           
     2               GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                           
     3               OK,LONBAD,LATBAD,                                                                                              
     4               GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                 
     5               VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                     
C                                                                                                                                   
        IF(.NOT.OK)THEN                                                                                                             
          WRITE(6,6030) LONBAD,LATBAD                                                                                               
          CALL                                     XIT('INCHEM3',-14)                                                               
        ENDIF                                                                                                                       
C                                                                                                                                   
C       * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                           
C                                                                                                                                   
        DO 240 I=1,LGG                                                                                                              
          IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                          
  240   CONTINUE                                                                                                                    
C                                                                                                                                   
        CALL SETLAB(IBUF,NC4TO8("GRID"),NDAY,NC4TO8("EBWA"),                                                                        
     +                                   LEVC(K),ILG1,ILAT,0,NPGG)                                                                  
        CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                
        WRITE(6,6026) IBUF                                                                                                          
  260   CONTINUE                                                                                                                    
  261 CONTINUE                                                                                                                      
C------------------------------------------------------------------------                                                           
      DO 271 N=1,NMO                                                                                                                
      DO 270 K=1,NLEV                                                                                                               
        NDAY=MMD(N)                                                                                                                 
C                                                                                                                                   
C       * GET GFED POM EMISSIONS AND AREA-AVERAGE TO GAUSSIAN GRID.                                                                 
                                                                                                                                    
        CALL GETFLD2(-1,GLL,NC4TO8("GRID"),MMD(N),NC4TO8("EOWA"),                                                                   
     +                                         LEVC(K),IBUF,MAXX,OK)                                                                
        IF(.NOT.OK) CALL                           XIT('INCHEM3',-15)                                                               
        IF(IBUF(5).NE.NLG.OR.IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-16)                                                               
        WRITE(6,6025) IBUF                                                                                                          
C                                                                                                                                   
        IOPTION=0                                                                                                                   
        ICHOICE=1                                                                                                                   
        CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                            
     1               LONM,LONP,LATM,LATP,                                                                                           
     2               GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                           
     3               OK,LONBAD,LATBAD,                                                                                              
     4               GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                 
     5               VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                     
C                                                                                                                                   
        IF(.NOT.OK)THEN                                                                                                             
          WRITE(6,6030) LONBAD,LATBAD                                                                                               
          CALL                                     XIT('INCHEM3',-17)                                                               
        ENDIF                                                                                                                       
C                                                                                                                                   
C       * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                           
C                                                                                                                                   
        DO 265 I=1,LGG                                                                                                              
          IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                          
  265   CONTINUE                                                                                                                    
C                                                                                                                                   
        CALL SETLAB(IBUF,NC4TO8("GRID"),NDAY,NC4TO8("EOWA"),                                                                        
     +                                  LEVC(K),ILG1,ILAT,0,NPGG)                                                                   
        CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                
        WRITE(6,6026) IBUF                                                                                                          
  270   CONTINUE                                                                                                                    
  271 CONTINUE                                                                                                                      
C------------------------------------------------------------------------                                                           
      DO 281 N=1,NMO                                                                                                                
      DO 280 K=1,NLEV                                                                                                               
        NDAY=MMD(N)                                                                                                                 
C                                                                                                                                   
C       * GET GFED SO2 EMISSIONS AND AREA-AVERAGE TO GAUSSIAN GRID.                                                                 
                                                                                                                                    
        CALL GETFLD2(-1,GLL,NC4TO8("GRID"),MMD(N),NC4TO8("ESWA"),                                                                   
     +                                          LEVC(K),IBUF,MAXX,OK)                                                               
        IF(.NOT.OK) CALL                           XIT('INCHEM3',-18)                                                               
        IF(IBUF(5).NE.NLG.OR.IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-19)                                                               
        WRITE(6,6025) IBUF                                                                                                          
C                                                                                                                                   
        IOPTION=0                                                                                                                   
        ICHOICE=1                                                                                                                   
        CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                            
     1               LONM,LONP,LATM,LATP,                                                                                           
     2               GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                           
     3               OK,LONBAD,LATBAD,                                                                                              
     4               GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                 
     5               VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                     
C                                                                                                                                   
        IF(.NOT.OK)THEN                                                                                                             
          WRITE(6,6030) LONBAD,LATBAD                                                                                               
          CALL                                     XIT('INCHEM3',-20)                                                               
        ENDIF                                                                                                                       
C                                                                                                                                   
C       * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                           
C                                                                                                                                   
        DO 275 I=1,LGG                                                                                                              
          IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                          
  275   CONTINUE                                                                                                                    
C                                                                                                                                   
        CALL SETLAB(IBUF,NC4TO8("GRID"),NDAY,NC4TO8("ESWA"),                                                                        
     +                                  LEVC(K),ILG1,ILAT,0,NPGG)                                                                   
        CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                
        WRITE(6,6026) IBUF                                                                                                          
  280   CONTINUE                                                                                                                    
  281 CONTINUE                                                                                                                      
C------------------------------------------------------------------------                                                           
      DO 282 N=1,NMO                                                                                                                
         NDAY=MMD(N)                                                                                                                
C------------------------------------------------------------------------                                                           
C       * GET SOA EMISSIONS AND AREA-AVERAGE TO GAUSSIAN GRID.                                                                      
                                                                                                                                    
        CALL GETFLD2(-1,GLL,NC4TO8("GRID"),MMD(N),NC4TO8("EOST"),                                                                   
     +                                            1,IBUF,MAXX,OK)                                                                   
        IF(.NOT.OK) CALL                           XIT('INCHEM3',-21)                                                               
        IF(IBUF(5).NE.NLG.OR.IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-22)                                                               
        WRITE(6,6025) IBUF                                                                                                          
C                                                                                                                                   
        IOPTION=0                                                                                                                   
        ICHOICE=1                                                                                                                   
        CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                            
     1               LONM,LONP,LATM,LATP,                                                                                           
     2               GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                           
     3               OK,LONBAD,LATBAD,                                                                                              
     4               GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                 
     5               VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                     
C                                                                                                                                   
        IF(.NOT.OK)THEN                                                                                                             
          WRITE(6,6030) LONBAD,LATBAD                                                                                               
          CALL                                     XIT('INCHEM3',-23)                                                               
        ENDIF                                                                                                                       
C                                                                                                                                   
C       * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                           
C                                                                                                                                   
        DO I=1,LGG                                                                                                                  
          IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                          
        ENDDO                                                                                                                       
C                                                                                                                                   
        CALL SETLAB(IBUF,NC4TO8("GRID"),NDAY,NC4TO8("EOST"),                                                                        
     +                                   1,ILG1,ILAT,0,NPGG)                                                                        
        CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                
        WRITE(6,6026) IBUF                                                                                                          
                                                                                                                                    
 282    CONTINUE                                                                                                                    
C=====================================================================                                                              
C     * INVARIANT FIELDS:                                                                                                           
C------------------------------------------------------------------------                                                           
C       * GET BIOFUEL BC EMISSIONS AND AREA-AVERAGE TO GAUSSIAN GRID.                                                               
                                                                                                                                    
        CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("EBBT"),                                                                        
     +                                            1,IBUF,MAXX,OK)                                                                   
        IF(.NOT.OK) CALL                           XIT('INCHEM3',-24)                                                               
        IF(IBUF(5).NE.NLG.OR.IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-25)                                                               
        WRITE(6,6025) IBUF                                                                                                          
C                                                                                                                                   
        IOPTION=0                                                                                                                   
        ICHOICE=1                                                                                                                   
        CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                            
     1               LONM,LONP,LATM,LATP,                                                                                           
     2               GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                           
     3               OK,LONBAD,LATBAD,                                                                                              
     4               GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                 
     5               VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                     
C                                                                                                                                   
        IF(.NOT.OK)THEN                                                                                                             
          WRITE(6,6030) LONBAD,LATBAD                                                                                               
          CALL                                     XIT('INCHEM3',-26)                                                               
        ENDIF                                                                                                                       
C                                                                                                                                   
C       * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                           
C                                                                                                                                   
        DO I=1,LGG                                                                                                                  
          IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                          
        ENDDO                                                                                                                       
C                                                                                                                                   
        CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("EBBT"),                                                                           
     +                                   1,ILG1,ILAT,0,NPGG)                                                                        
        CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                
        WRITE(6,6026) IBUF                                                                                                          
C------------------------------------------------------------------------                                                           
C       * GET BIOFUEL POM EMISSIONS AND AREA-AVERAGE TO GAUSSIAN GRID.                                                              
                                                                                                                                    
        CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("EOBT"),                                                                        
     +                                            1,IBUF,MAXX,OK)                                                                   
        IF(.NOT.OK) CALL                           XIT('INCHEM3',-27)                                                               
        IF(IBUF(5).NE.NLG.OR.IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-28)                                                               
        WRITE(6,6025) IBUF                                                                                                          
C                                                                                                                                   
        IOPTION=0                                                                                                                   
        ICHOICE=1                                                                                                                   
        CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                            
     1               LONM,LONP,LATM,LATP,                                                                                           
     2               GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                           
     3               OK,LONBAD,LATBAD,                                                                                              
     4               GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                 
     5               VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                     
C                                                                                                                                   
        IF(.NOT.OK)THEN                                                                                                             
          WRITE(6,6030) LONBAD,LATBAD                                                                                               
          CALL                                     XIT('INCHEM3',-29)                                                               
        ENDIF                                                                                                                       
C                                                                                                                                   
C       * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                           
C                                                                                                                                   
        DO I=1,LGG                                                                                                                  
          IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                          
        ENDDO                                                                                                                       
C                                                                                                                                   
        CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("EOBT"),                                                                           
     +                                   1,ILG1,ILAT,0,NPGG)                                                                        
        CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                
        WRITE(6,6026) IBUF                                                                                                          
C------------------------------------------------------------------------                                                           
C       * GET FOSSIL FUEL BC EMISSIONS AND AREA-AVERAGE TO GAUSSIAN GRID.                                                           
                                                                                                                                    
        CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("EBFT"),                                                                        
     +                                            1,IBUF,MAXX,OK)                                                                   
        IF(.NOT.OK) CALL                           XIT('INCHEM3',-30)                                                               
        IF(IBUF(5).NE.NLG.OR.IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-31)                                                               
        WRITE(6,6025) IBUF                                                                                                          
C                                                                                                                                   
        IOPTION=0                                                                                                                   
        ICHOICE=1                                                                                                                   
        CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                            
     1               LONM,LONP,LATM,LATP,                                                                                           
     2               GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                           
     3               OK,LONBAD,LATBAD,                                                                                              
     4               GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                 
     5               VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                     
C                                                                                                                                   
        IF(.NOT.OK)THEN                                                                                                             
          WRITE(6,6030) LONBAD,LATBAD                                                                                               
          CALL                                     XIT('INCHEM3',-32)                                                               
        ENDIF                                                                                                                       
C                                                                                                                                   
C       * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                           
C                                                                                                                                   
        DO I=1,LGG                                                                                                                  
          IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                          
        ENDDO                                                                                                                       
C                                                                                                                                   
        CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("EBFT"),                                                                           
     +                                   1,ILG1,ILAT,0,NPGG)                                                                        
        CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                
        WRITE(6,6026) IBUF                                                                                                          
C---------------------------------------------------------------------                                                              
C       * GET FOSSIL FUEL POM EMISSIONS AND AREA-AVERAGE TO GAUSSIAN GRID.                                                          
                                                                                                                                    
        CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("EOFT"),                                                                        
     +                                            1,IBUF,MAXX,OK)                                                                   
        IF(.NOT.OK) CALL                           XIT('INCHEM3',-33)                                                               
        IF(IBUF(5).NE.NLG.OR.IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-34)                                                               
        WRITE(6,6025) IBUF                                                                                                          
C                                                                                                                                   
        IOPTION=0                                                                                                                   
        ICHOICE=1                                                                                                                   
        CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                            
     1               LONM,LONP,LATM,LATP,                                                                                           
     2               GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                           
     3               OK,LONBAD,LATBAD,                                                                                              
     4               GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                 
     5               VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                     
C                                                                                                                                   
        IF(.NOT.OK)THEN                                                                                                             
          WRITE(6,6030) LONBAD,LATBAD                                                                                               
          CALL                                     XIT('INCHEM3',-35)                                                               
        ENDIF                                                                                                                       
C                                                                                                                                   
C       * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                           
C                                                                                                                                   
        DO I=1,LGG                                                                                                                  
          IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                          
        ENDDO                                                                                                                       
C                                                                                                                                   
        CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("EOFT"),                                                                           
     +                                   1,ILG1,ILAT,0,NPGG)                                                                        
        CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                
        WRITE(6,6026) IBUF                                                                                                          
C---------------------------------------------------------------------                                                              
C     * SO2 EMISSIONS FROM DOMESTIC USE                                                                                             
C                                                                                                                                   
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("ESDT"),                                                                          
     +                                     1,IBUF,MAXX,OK)                                                                          
      IF(.NOT.OK) CALL                             XIT('INCHEM3',-36)                                                               
      IF(IBUF(5).NE.NLG .OR. IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-37)                                                               
      WRITE(6,6025) IBUF                                                                                                            
C                                                                                                                                   
      IOPTION=0                                                                                                                     
      ICHOICE=1                                                                                                                     
      CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                              
     1             LONM,LONP,LATM,LATP,                                                                                             
     2             GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                             
     3             OK,LONBAD,LATBAD,                                                                                                
     4             GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                   
     5             VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                       
C                                                                                                                                   
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL                                       XIT('INCHEM3',-38)                                                               
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                             
C                                                                                                                                   
      DO I=1,LGG                                                                                                                    
        IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                            
      ENDDO                                                                                                                         
C                                                                                                                                   
      CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("ESDT"),1,                                                                           
     +                                  ILG1,ILAT,0,NPGG)                                                                           
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
C---------------------------------------------------------------------                                                              
C     * SO2 EMISSIONS FROM INDUSTRIAL USE                                                                                           
C                                                                                                                                   
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("ESIT"),                                                                          
     +                                     1,IBUF,MAXX,OK)                                                                          
      IF(.NOT.OK) CALL                             XIT('INCHEM3',-39)                                                               
      IF(IBUF(5).NE.NLG .OR. IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-40)                                                               
      WRITE(6,6025) IBUF                                                                                                            
C                                                                                                                                   
      IOPTION=0                                                                                                                     
      ICHOICE=1                                                                                                                     
      CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                              
     1             LONM,LONP,LATM,LATP,                                                                                             
     2             GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                             
     3             OK,LONBAD,LATBAD,                                                                                                
     4             GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                   
     5             VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                       
C                                                                                                                                   
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL                                       XIT('INCHEM3',-41)                                                               
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                             
C                                                                                                                                   
      DO I=1,LGG                                                                                                                    
        IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                            
      ENDDO                                                                                                                         
C                                                                                                                                   
      CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("ESIT"),1,                                                                           
     +                                  ILG1,ILAT,0,NPGG)                                                                           
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
C---------------------------------------------------------------------                                                              
C     * SO2 EMISSIONS FROM INTERNATIONAL SHIPPING                                                                                   
C                                                                                                                                   
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("ESST"),                                                                          
     +                                     1,IBUF,MAXX,OK)                                                                          
      IF(.NOT.OK) CALL                             XIT('INCHEM3',-42)                                                               
      IF(IBUF(5).NE.NLG .OR. IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-43)                                                               
      WRITE(6,6025) IBUF                                                                                                            
C                                                                                                                                   
      IOPTION=0                                                                                                                     
      ICHOICE=1                                                                                                                     
      CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                              
     1             LONM,LONP,LATM,LATP,                                                                                             
     2             GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                             
     3             OK,LONBAD,LATBAD,                                                                                                
     4             GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                   
     5             VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                       
C                                                                                                                                   
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL                                       XIT('INCHEM3',-44)                                                               
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                             
C                                                                                                                                   
      DO I=1,LGG                                                                                                                    
        IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                            
      ENDDO                                                                                                                         
C                                                                                                                                   
      CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("ESST"),1,                                                                           
     +                                  ILG1,ILAT,0,NPGG)                                                                           
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
C---------------------------------------------------------------------                                                              
C     * SO2 EMISSIONS FROM OFF-ROAD USE                                                                                             
C                                                                                                                                   
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("ESOT"),                                                                          
     +                                     1,IBUF,MAXX,OK)                                                                          
      IF(.NOT.OK) CALL                             XIT('INCHEM3',-45)                                                               
      IF(IBUF(5).NE.NLG .OR. IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-46)                                                               
      WRITE(6,6025) IBUF                                                                                                            
C                                                                                                                                   
      IOPTION=0                                                                                                                     
      ICHOICE=1                                                                                                                     
      CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                              
     1             LONM,LONP,LATM,LATP,                                                                                             
     2             GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                             
     3             OK,LONBAD,LATBAD,                                                                                                
     4             GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                   
     5             VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                       
C                                                                                                                                   
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL                                       XIT('INCHEM3',-47)                                                               
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                             
C                                                                                                                                   
      DO I=1,LGG                                                                                                                    
        IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                            
      ENDDO                                                                                                                         
C                                                                                                                                   
      CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("ESOT"),1,                                                                           
     +                                  ILG1,ILAT,0,NPGG)                                                                           
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
C---------------------------------------------------------------------                                                              
C     * SO2 EMISSIONS FROM POWER PLANTS                                                                                             
C                                                                                                                                   
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("ESPT"),                                                                          
     +                                     1,IBUF,MAXX,OK)                                                                          
      IF(.NOT.OK) CALL                             XIT('INCHEM3',-48)                                                               
      IF(IBUF(5).NE.NLG .OR. IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-49)                                                               
      WRITE(6,6025) IBUF                                                                                                            
C                                                                                                                                   
      IOPTION=0                                                                                                                     
      ICHOICE=1                                                                                                                     
      CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                              
     1             LONM,LONP,LATM,LATP,                                                                                             
     2             GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                             
     3             OK,LONBAD,LATBAD,                                                                                                
     4             GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                   
     5             VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                       
C                                                                                                                                   
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL                                       XIT('INCHEM3',-50)                                                               
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                             
C                                                                                                                                   
      DO I=1,LGG                                                                                                                    
        IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                            
      ENDDO                                                                                                                         
C                                                                                                                                   
      CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("ESPT"),1,                                                                           
     +                                  ILG1,ILAT,0,NPGG)                                                                           
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
C---------------------------------------------------------------------                                                              
C     * SO2 EMISSIONS FROM ROADS                                                                                                    
C                                                                                                                                   
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("ESRT"),                                                                          
     +                                     1,IBUF,MAXX,OK)                                                                          
      IF(.NOT.OK) CALL                             XIT('INCHEM3',-51)                                                               
      IF(IBUF(5).NE.NLG .OR. IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-52)                                                               
      WRITE(6,6025) IBUF                                                                                                            
C                                                                                                                                   
      IOPTION=0                                                                                                                     
      ICHOICE=1                                                                                                                     
      CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                              
     1             LONM,LONP,LATM,LATP,                                                                                             
     2             GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                             
     3             OK,LONBAD,LATBAD,                                                                                                
     4             GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                   
     5             VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                       
C                                                                                                                                   
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL                                       XIT('INCHEM3',-53)                                                               
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                             
C                                                                                                                                   
      DO I=1,LGG                                                                                                                    
        IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                            
      ENDDO                                                                                                                         
C                                                                                                                                   
      CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("ESRT"),1,                                                                           
     +                                  ILG1,ILAT,0,NPGG)                                                                           
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
C---------------------------------------------------------------------                                                              
C     * SO2 EMISSIONS FROM CONTINUOUS VOLCANOES.                                                                                    
C                                                                                                                                   
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("ESCV"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INCHEM3',-54)                                                               
      IF(IBUF(5).NE.NLG .OR. IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-55)                                                               
      WRITE(6,6025) IBUF                                                                                                            
C                                                                                                                                   
      IOPTION=0                                                                                                                     
      ICHOICE=1                                                                                                                     
      CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                              
     1             LONM,LONP,LATM,LATP,                                                                                             
     2             GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                             
     3             OK,LONBAD,LATBAD,                                                                                                
     4             GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                   
     5             VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                       
C                                                                                                                                   
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL                                       XIT('INCHEM3',-56)                                                               
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                             
C                                                                                                                                   
      DO I=1,LGG                                                                                                                    
        IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                            
      ENDDO                                                                                                                         
C                                                                                                                                   
      CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("ESCV"),1,                                                                           
     +                                  ILG1,ILAT,0,NPGG)                                                                           
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
C---------------------------------------------------------------------                                                              
C     * HEIGHT OF CONTINUOUS VOLCANOES.                                                                                             
C                                                                                                                                   
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("EHCV"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INCHEM3',-57)                                                               
      IF(IBUF(5).NE.NLG .OR. IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-58)                                                               
      WRITE(6,6025) IBUF                                                                                                            
C                                                                                                                                   
      IOPTION=1                                                                                                                     
      ICHOICE=4                                                                                                                     
      CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                              
     1             LONM,LONP,LATM,LATP,                                                                                             
     2             GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                             
     3             OK,LONBAD,LATBAD,                                                                                                
     4             GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                   
     5             VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                       
C                                                                                                                                   
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL                                       XIT('INCHEM3',-59)                                                               
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * CONVERT FROM HEIGHT IN METRES ABOVE SEA LEVEL (IN "GH") TO HEIGHT                                                           
C     * IN METRES ABOVE GROUND, BY SUBTRACTING OFF SURFACE HEIGHT (OBTAINED                                                         
C     * FROM "GG") AND CLIPPING NEGATIVE VALUES.                                                                                    
C                                                                                                                                   
      GINV=1./9.80616                                                                                                               
      DO I=1,LGG                                                                                                                    
          GH(I)=MAX(0.E0, GH(I)-MAX(0.E0,GINV*GG(I)))                                                                               
      ENDDO                                                                                                                         
C                                                                                                                                   
C     * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                             
C                                                                                                                                   
      DO I=1,LGG                                                                                                                    
        IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                            
      ENDDO                                                                                                                         
C                                                                                                                                   
      CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("EHCV"),1,                                                                           
     +                                  ILG1,ILAT,0,NPGG)                                                                           
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
C---------------------------------------------------------------------                                                              
C     * SO2 EMISSIONS FROM EXPLOSIVE VOLCANOES.                                                                                     
C                                                                                                                                   
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("ESEV"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INCHEM3',-60)                                                               
      IF(IBUF(5).NE.NLG .OR. IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-61)                                                               
      WRITE(6,6025) IBUF                                                                                                            
C                                                                                                                                   
      IOPTION=0                                                                                                                     
      ICHOICE=1                                                                                                                     
      CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                              
     1             LONM,LONP,LATM,LATP,                                                                                             
     2             GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                             
     3             OK,LONBAD,LATBAD,                                                                                                
     4             GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                   
     5             VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                       
C                                                                                                                                   
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL                                       XIT('INCHEM3',-62)                                                               
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                             
C                                                                                                                                   
      DO I=1,LGG                                                                                                                    
        IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                            
      ENDDO                                                                                                                         
C                                                                                                                                   
      CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("ESEV"),1,                                                                           
     +                                  ILG1,ILAT,0,NPGG)                                                                           
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
C---------------------------------------------------------------------                                                              
C     * HEIGHT OF EXPLOSIVE VOLCANOES.                                                                                              
C                                                                                                                                   
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("EHEV"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INCHEM3',-63)                                                               
      IF(IBUF(5).NE.NLG .OR. IBUF(6).NE.NLAT) CALL XIT('INCHEM3',-64)                                                               
      WRITE(6,6025) IBUF                                                                                                            
C                                                                                                                                   
      IOPTION=1                                                                                                                     
      ICHOICE=4                                                                                                                     
      CALL HRTOLR4(GH,MASKTMP,ILG1,ILAT,DLON,DLAT,ILG,                                                                              
     1             LONM,LONP,LATM,LATP,                                                                                             
     2             GLL,HRMASK,NLG,NLAT,IOPTION,ICHOICE,                                                                             
     3             OK,LONBAD,LATBAD,                                                                                                
     4             GCLRTMP,GCHRTMP,RLON,RLAT,LATL,LATH,LONL,LONH,                                                                   
     5             VAL,DIST,LOCAT,IVAL,LOCFST,LONB,LATB,NMAX)                                                                       
C                                                                                                                                   
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL                                       XIT('INCHEM3',-65)                                                               
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * CONVERT FROM HEIGHT IN METRES ABOVE SEA LEVEL (IN "GH") TO HEIGHT                                                           
C     * IN METRES ABOVE GROUND, BY SUBTRACTING OFF SURFACE HEIGHT (OBTAINED                                                         
C     * FROM "GG") AND CLIPPING NEGATIVE VALUES.                                                                                    
C                                                                                                                                   
      GINV=1./9.80616                                                                                                               
      DO I=1,LGG                                                                                                                    
          GH(I)=MAX(0.E0, GH(I)-MAX(0.E0,GINV*GG(I)))                                                                               
      ENDDO                                                                                                                         
C                                                                                                                                   
C     * PUT BACK REPRESENTATIVE VALUES OVER ANTARCTICA.                                                                             
C                                                                                                                                   
      DO I=1,LGG                                                                                                                    
        IF(I.LE.IGLAC .AND. MASK(I).EQ.-1.E0) GH(I)=0.E0                                                                            
      ENDDO                                                                                                                         
C                                                                                                                                   
      CALL SETLAB(IBUF,NC4TO8("GRID"),0,NC4TO8("EHEV"),1,                                                                           
     +                                  ILG1,ILAT,0,NPGG)                                                                           
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
C---------------------------------------------------------------------                                                              
C     * E.O.F. ON FILE LL.                                                                                                          
                                                                                                                                    
      CALL                                         XIT('INCHEM3',0)                                                                 
                                                                                                                                    
C     * E.O.F. ON FILE ICTL.                                                                                                        
                                                                                                                                    
  910 CALL                                         XIT('INCHEM3',-66)                                                               
  911 CALL                                         XIT('INCHEM3',-67)                                                               
C---------------------------------------------------------------------                                                              
 6010 FORMAT('0IDAY,ILG1,ILAT =',3I6)                                                                                               
 6025 FORMAT(' ',A4,I10,1X,A4,5I6)                                                                                                  
 6026 FORMAT(' ',60X,A4,I10,1X,A4,5I6)                                                                                              
 6030 FORMAT('0EXITING PROGRAM; NO POINTS FOUND WITHIN GRID SQUARE',                                                                
     1       ' CENTRED AT (',I3,',',I3,')')                                                                                         
      END                                                                                                                           
