      PROGRAM INITGG6                                                                                                               
C     PROGRAM INITGG6 (ICTL,       LLPHYS,       GGPHYS,       OUTPUT,  )       I2                                                  
C    1          TAPE99=ICTL, TAPE1=LLPHYS, TAPE2=GGPHYS, TAPE6=OUTPUT)                                                              
C     ----------------------------------------------------------------          I2                                                  
C                                                                               I2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       I2                                                  
C     MAY 09/96 - F.MAJAESS (CORRECT LLIGG2 CALL AND DIMENSION SELECTED                                                             
C                            VARIABLES AS REAL*8)                                                                                   
C     NOV 06/95 - F.MAJAESS (REVISE DEFAULT PACKING DENSITY VALUE)                                                                  
C     MAR 17/93 - E.CHAN   (DO NOT REWIND UNIT 99 WHEN USING GETFLD2)                                                               
C     JAN 14/92 - E.CHAN   (CONVERT HOLLERITH TO ASCII AND REDUCE PACKING                                                           
C                           DENSITY FOR GC TO 6)                                                                                    
C     JAN 22/91 - F.MAJAESS(INCREASE DIMENSION OF "GL" ARRAY)                                                                       
C     AUG 13/90 - M.LAZARE.   REPLACE DRAG FIELD BY THAT CALCULATED BY INPUT                                                        
C                             LN(Z0) FIELD.                                                                                         
C     DEC 29/89 - D.VERSEGHY. BASED ON INITGG5, INCORPORATING NEW FIELDS                                                            
C                             REQUIRED FOR CLASS ("CANADIAN LAND SURFACE                                                            
C                             SCHEME").                                                                                             
C                                                                               I2                                                  
CINITGG6 - GRID PHYSICS INITIALIZATION PROGRAM FOR GCM7                 2  1    I1                                                  
C                                                                               I3                                                  
CPURPOSE - CONVERTS HIGH-RESOLUTION LAT-LONG SURFACE PHYSICS GRIDS TO           I3                                                  
C          GAUSSIAN GRIDS.                                                      I3                                                  
C          NOTE - ALL INITIAL SURFACE FIELDS ARE AT 1X1 DEGREE RESOLUTION.      I3                                                  
C                 THE GROUND COVER, GROUND TEMPERATURE AND SEA ICE FIELDS       I3                                                  
C                 MUST BE AVAILABLE FOR ALL MONTHS. THE SNOW COVER, LIQUID      I3                                                  
C                 AND FROZEN WATER FIELDS ARE REQUIRED FOR ANY MONTH THE        I3                                                  
C                 MODEL STARTS FROM. (I.E. PROGRAM ABORTS IF AISW, AITW,        I3                                                  
C                 AL, ALSW, ALLW, AVSW, AVTW, ENV, FCS, FCT, GC, GT,            I3                                                  
C                 LNZ0, PVEG, SVEG, SOIL OR PGND ARE MISSING; SNO, WL AND       I3                                                  
C                 WF ARE NEEDED ONLY FOR INITIAL STARTUPS).                     I3                                                  
C                 ALL OTHER FIELDS HAVE ONE BASIC ANNUAL VALUE.                 I3                                                  
C                 THE DISCRETE FIELDS ARE CONSIDERED TO BE GC, PVEG, SVEG AND   I3                                                  
C                 SOIL. ALL OTHERS ARE AREA-AVERAGED.                           I3                                                  
C                 AS WELL, THE SURFACE HEIGHT FIELD (ON THE ANALYSIS GAUSSIAN   I3                                                  
C                 GRID) IS OBTAINED FROM THE CONTROL FILE (AFTER CONVERTING     I3                                                  
C                 FROM GEOPOTENTIAL TO HEIGHT) AND SAVED ON THE AN FILE FOR     I3                                                  
C                 DISPLAY PURPOSES.                                             I3                                                  
C                 INITIAL FIELDS AT 1X1 DEGREE RESOLUTION ARE EITHER AREA-      I3                                                  
C                 AVERAGED (CONTINUOUS) OR THEIR MOST-FREQUENTLY OCCURRING      I3                                                  
C                 VALUE IN THE MODEL-RESOLUTION GRID SQUARE CHOSEN (DISCRETE-   I3                                                  
C                 VALUED) USING THE SUBROUTINE HRALR, WHICH USES THE GROUND     I3                                                  
C                 COVER INFORMATION IN PROCESSING THE DATA.                     I3                                                  
C                 FOR INITIAL FIELDS AT LOWER RESOLUTION, OR FOR THE GROUND     I3                                                  
C                 COVER ITSELF, THE ROUTINE HRTOLR IS USED, FOR EITHER          I3                                                  
C                 DISCRETE-VALUED OR CONTINUOUS FIELDS.                         I3                                                  
C                 THE SOIL FIELD IS TREATED SOMEWHAT DIFFERENTLY. IF IHYD=2,    I3                                                  
C                 THE SOIL COLOUR AND CLAYINESS ARE OBTAINED ON A SCALE OF      I3                                                  
C                 1 TO 12 (DARK TO LIGHT, COARSE TO FINE), AND THE SOIL         I3                                                  
C                 SANDINESS AND DRAINAGE ARE OBTAINED ON A SCALE OF 1 TO 15     I3                                                  
C                 (FINE TO COARSE, POOR TO FREE) RESPECTIVELY ON THE 1X1        I3                                                  
C                 DEGREE GRID AND ARE AREA-AVERAGED USING HRALR. THE VALUES     I3                                                  
C                 WHICH RESULT FOR EACH LOW-RESOLUTION GRID SQUARE ARE THEN     I3                                                  
C                 CONCATENATED INTO ONE EIGHT-DIGIT NUMBER, WHOSE FOUR          I3                                                  
C                 SUCCESSIVE PAIRS OF DIGITS REPRESENT COLOUR, SANDINESS,       I3                                                  
C                 CLAYINESS AND DRAINAGE RESPECTIVELY.                          I3                                                  
C                 IF IHYD<2, ON THE OTHER HAND, EACH OF THE THREE SOIL          I3                                                  
C                 PROPERTIES OF COLOUR, TEXTURE AND DRAINAGE IS OBTAINED        I3                                                  
C                 ON A SCALE OF 1-3 (DARK-LIGHT, FINE-COARSE AND FREE-POOR,     I3                                                  
C                 RESPECTIVELY) ON THE 1X1 DEGREE GRID AND AREA-AVERAGED        I3                                                  
C                 USING HRALR. THE RESULTING LOW-RESOLUTION GRID VALUE FOR      I3                                                  
C                 EACH GRID POINT IS THEN STRETCHED TO ENCOMPASS THE RANGE      I3                                                  
C                 0-9. FINALLY, THE ONE-DIGIT RESULTS FOR EACH OF THE 3         I3                                                  
C                 PROPERTIES ARE CONCATENATED INTO ONE 5-DIGIT NUMBER, WHEREBY  I3                                                  
C                 THE 10,000'S DIGIT REPRESENTS COLOUR, THE 1000'S DIGIT        I3                                                  
C                 REPRESENTS TEXTURE AND THE 100'S DIGIT REPRESENTS DRAINAGE.   I3                                                  
C                 THE REMAINING 2 DIGITS TAKE THE VALUE 09 TO DISTINGUISH LAND  I3                                                  
C                 POINTS FROM WATER OR SEA-ICE POINTS (WHICH HAVE THE VALUE 0)  I3                                                  
C                 OR FROM GLACIER ICE POINTS (WHICH HAVE THE VALUE 32). THESE   I3                                                  
C                 VALUES ARE DECOMPOSED IN THE MODEL TO ALLOW FOR PARAMETRIZA-  I3                                                  
C                 TIONS OF HYDROLOGICAL PARAMETERS WHICH DEPEND ON THESE SOIL   I3                                                  
C                 PROPERTIES.                                                   I3                                                  
C                 FINALLY, AT THE END, THE SPECTRALLY SMOOTHED PHIS FIELD FROM  I3                                                  
C                 THE CONTROL FILE IS ALSO SAVED, FOR DISPLAY PURPOSES.         I3                                                  
C                                                                               I3                                                  
CINPUT FILES...                                                                 I3                                                  
C                                                                               I3                                                  
C      ICTL   = CONTAINS GLOBAL LAT-LONG GRIDS WHICH ARE READ AND HORIZONTALLY  I3                                                  
C               SMOOTHED TO GLOBAL GAUSSIAN GRIDS. THE LAT LONG GRIDS MAY BE    I3                                                  
C               IN ANY ORDER ON THIS FILE.                                      I3                                                  
C                                                                               I3                                                  
C      LLPHYS = LAT-LONG PHYSICS GRIDS:                                         I3                                                  
C                                                                               I3                                                  
C      NAME            VARIABLE                      UNITS                      I3                                                  
C      ----            --------                      -----                      I3                                                  
C                                                                               I3                                                  
C      AISW   WEIGHTED NEAR-IR SHORT CANOPY ALBEDO   PERCENTAGE                 I3                                                  
C      AITW   WEIGHTED NEAR-IR TALL CANOPY ALBEDO    PERCENTAGE                 I3                                                  
C        AL   ALBEDO (SFC) (NOT USED CURRENTLY)      PERCENTAGE                 I3                                                  
C      ALLW   NEAR-IR CANOPY ALBEDO (SFC)            PERCENTAGE                 I3                                                  
C      ALSW   VISIBLE CANOPY ALBEDO (SFC)            PERCENTAGE                 I3                                                  
C      AVSW   WEIGHTED VISIBLE SHORT CANOPY ALBEDO   PERCENTAGE                 I3                                                  
C      AVTW   WEIGHTED VISIBLE TALL CANOPY ALBEDO    PERCENTAGE                 I3                                                  
C       ENV   ENVELOPE OROGRAPHY                     METRES                     I3                                                  
C       FCS   AREAL FRACTION OF SHORT CANOPY         FRACTION                   I3                                                  
C       FCT   AREAL FRACTION OF TALL CANOPY          FRACTION                   I3                                                  
C        GC   GROUND COVER                           -1.=LAND,0.=SEA,+1.=ICE    I3                                                  
C        GT   GROUND TEMPERATURE                     DEG K                      I3                                                  
C      LNZ0   LN OF SURFACE ROUGHNESS LENGTH           -                        I3                                                  
C      PGND   AREAL FRACTION OF BARE SOIL            FRACTION                   I3                                                  
C      PVEG   PRIMARY VEGETATION TYPE                0-24                       I3                                                  
C       SIC   SEA ICE AMOUNT                         KG/M**2                    I3                                                  
C       SNO   SNOW DEPTH                             KG/M**2 = MM WATER DEPTH   I3                                                  
C      SOIL   SOIL CLASS                             11-32                      I3                                                  
C      SVEG   SECONDARY VEGETATION TYPE              0-24                       I3                                                  
C        WF   FROZEN GROUND WATER                    FRACTION OF CAPACITY       I3                                                  
C        WL   LIQUID GROUND WATER                    FRACTION OF CAPACITY       I3                                                  
C                                                                               I3                                                  
COUTPUT FILE...                                                                 I3                                                  
C                                                                               I3                                                  
C      GGPHYS = GAUSSIAN GRID SURFACE PHYSICS FIELDS:                           I3                                                  
C                                                                               I3                                                  
C      NAME            VARIABLE                      UNITS                      I3                                                  
C      ----            --------                      -----                      I3                                                  
C                                                                               I3                                                  
C        AL   ALBEDO (SFC) (NOT USED CURRENTLY)      FRACTION                   I3                                                  
C      ALIC   NEAR-IR CANOPY ALBEDO (TALL & SHORT)   FRACTION                   I3                                                  
C      ALLW   NEAR-IR CANOPY ALBEDO (SFC)            FRACTION                   I3                                                  
C      ALSW   VISIBLE CANOPY ALBEDO (SFC)            FRACTION                   I3                                                  
C      ALVC   VISIBLE CANOPY ALBEDO (TALL & SHORT)   FRACTION                   I3                                                  
C        DR   DRAG (SFC)                               -                        I3                                                  
C       ENV   ENVELOPE OROGRAPHY                     METRES                     I3                                                  
C      FCAN   AREAL CANOPY FRACTION (TALL & SHORT)   FRACTION                   I3                                                  
C        GC   GROUND COVER                           -1.=LAND,0.=SEA,+1.=ICE    I3                                                  
C        GT   GROUND TEMPERATURE                     DEG K                      I3                                                  
C      LNZ0   LN OF ROUGHNESS LENGTH                   -                        I3                                                  
C      PGND   AREAL FRACTION OF BARE SOIL            FRACTION                   I3                                                  
C      PVEG   PRIMARY VEGETATION TYPE                0-24                       I3                                                  
C       SIC   SEA ICE AMOUNT                         KG/M**2                    I3                                                  
C       SNO   SNOW DEPTH                             KG/M**2 = MM WATER DEPTH   I3                                                  
C      SOIL   SOIL CLASS                             SEE NOTE ABOVE             I3                                                  
C      SVEG   SECONDARY VEGETATION TYPE              0-24                       I3                                                  
C        WF   FROZEN GROUND WATER                    FRACTION OF CAPACITY       I3                                                  
C        WL   LIQUID GROUND WATER                    FRACTION OF CAPACITY       I3                                                  
C        ZS   SURFACE HEIGHT ON ANALYSIS GRID        METRES                     I3                                                  
C             (NEGATIVE VALUES EXCISED)                                         I3                                                  
C-----------------------------------------------------------------------------                                                      
C                                                                                                                                   
C                                                                                                                                   
C     * SUBROUTINE HRALR IS USED FOR SMOOTHING FIELDS HAVING THE SAME HIGH                                                          
C     * RESOLUTION AS THAT OF THE GROUND COVER FIELD. ONLY THOSE SURROUNDING                                                        
C     * HIGH-RESOLUTION GRID POINTS HAVING THE SAME GROUND COVER AS THAT OF THE                                                     
C     * LOW-RESOLUTION GRID POINT ARE CONSIDERED. IF THE FIELD IS CONTINUOUS,                                                       
C     * AREA AVERAGING IS DONE; OTHERWISE THE MOST FREQUENTLY-OCCURRING POINT                                                       
C     * IS CHOSEN.                                                                                                                  
                                                                                                                                    
C     * SUBROUTINE HRTOLR IS USED FOR SMOOTHING THE GROUND COVER FIELD, OR                                                          
C     * FIELDS HAVING DIFFERENT HIGH-RESOLUTIONS FROM THAT OF THE GROUND                                                            
C     * COVER. IN THESE CASES, ALL HIGH-RESOLUTION GRID POINTS WITHIN THE                                                           
C     * LOW-RESOLUTION GRID SQUARE (REGARDLESS OF THEIR GROUND COVER) ARE                                                           
C     * USED IN THE CALCULATION. ONCE AGAIN, CONTINUOUS FIELDS ARE AREA-                                                            
C     * AVERAGED, WHILE DISCRETE FIELDS ARE SMOOTHED BY FINDING THE MOST                                                            
C     * FREQUENTLY-OCCURRING POINT.                                                                                                 
                                                                                                                                    
C     * IF NO HIGH-RESOLUTION POINTS ARE FOUND WITHIN A PARTICULAR LOW-                                                             
C     * RESOLUTION GRID SQUARE (I.E. IF THE INITIAL FIELD IS OF THE SAME SIZE,                                                      
C     * OR SMALLER, THAN THE GAUSSIAN GRID), THE CONVERSION IS DONE BY                                                              
C     * INTERPOLATION (CONTINUOUS FIELDS) OR EXTRACTION (DISCRETE-VALUE FIELDS).                                                    
                                                                                                                                    
C     * GLL IS THE FIELD READ IN FOR HIGH-RESOLUION LAT-LON FIELDS WHILE GL IS                                                      
C     * THE FIELD READ IN FOR LOW-RESOLUTION LAT-LON FIELDS (ALSO USED AS                                                           
C     * THE OUTPUT FIELD FOR PRIMARY VEGETATION, FOR CONSISTENCY CHECKS).                                                           
C     * LLGC IS THE HIGH-RESOLUTION LAT-LON GROUND COVER ARRAY WHILE GC IS THE                                                      
C     * GAUSSIAN-GRID GROUND COVER ARRAY.                                                                                           
C     * GH IS THE RESULTING OUTPUT FIELD ARRAY FOR ALL FIELDS.                                                                      
                                                                                                                                    
C     * GWH AND GWL ARE WORK FIELDS (HIGH-RESOLUTION AND LOW-RESOLUTION                                                             
C     * RESPECTIVELY) USED TO DETERMINE THE OUTPUT FIELD FOR SOIL                                                                   
C     * CLASS, WHICH CONTAINS AREA-AVERAGED INFORMATION ON COLOUR,                                                                  
C     * TEXTURE AND DRAINAGE, LATER DECOMPOSED IN THE MODEL.                                                                        
C     * GWL IS ALSO USED TO STORE THE AREAL FRACTIONS OF TALL AND SHORT                                                             
C     * CANOPY, SINCE THESE ARE REQUIRED TO CALCULATE THE AVERAGED                                                                  
C     * VISIBLE AND NEAR-IR ALBEDOES OF THE TWO CANOPY TYPES.                                                                       
C     * GT IS A LOW-RESOLUTION WORK FIELD USED FOR INTERIM STORAGE OF                                                               
C     * THE TEMPERATURE OF THE FIRST SOIL LAYER.                                                                                    
                                                                                                                                    
C     * COLOUR                                                                                                                      
C     * SAND    - LOOKUP TABLES FOR TRANSLATION OF SOIL CODES (0 TO 32)                                                             
C     * CLAY      INTO COLOUR, SANDINESS, CLAYINESS AND DRAINAGE CODES.                                                             
C     * DRAIN                                                                                                                       
C     *                                                                                                                             
C     * ISOIL   - LOOKUP TABLE FOR TRANSLATION OF ARCHIVED SOIL CODES (IN                                                           
C     *           RANGE 0 TO 32) TO COLOUR - TEXTURE - DRAINAGE CODE.                                                               
C     *           EACH SOIL PROPERTY IS CODED ON A SCALE FROM 1 TO 3:                                                               
C     *                                                                                                                             
C     *                              1          2            3                                                                      
C     *             COLOUR         DARK       MEDIUM       LIGHT                                                                    
C     *             TEXTURE        FINE       MEDIUM       COARSE                                                                   
C     *             DRAINAGE       FREE       IMPEDED      POOR                                                                     
C     *                                                                                                                             
C     *           WITH COLOUR AS THE HUNDREDS DIGIT, TEXTURE AS THE TENS                                                            
C     *           DIGIT, AND DRAINAGE AS THE UNITS DIGIT.                                                                           
C     *                                                                                                                             
C     * IPROP   - PROPERTY LIST FOR CURRENT HI-RES GRID POINT                                                                       
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      REAL GLL(65341),LLGC(65341),GWH(65341),GL(65341)                                                                              
      REAL GH(18528),GC(18528),GWL(18528),GT(18528)                                                                                 
      REAL*8 SL(181), CL(181), WL(181), WOSSL(181),                                                                                 
     1       RAD(181)                                                                                                               
      REAL DLAT(181), DLON(361)                                                                                                     
                                                                                                                                    
      LOGICAL OK                                                                                                                    
                                                                                                                                    
      REAL COLOUR(0:32),SAND(0:32),CLAY(0:32),DRAIN(0:32)                                                                           
      INTEGER ISOIL(0:32),NFDM(13)                                                                                                  
                                                                                                                                    
      COMMON/ICOM/IBUF(8),IDAT(65341)                                                                                               
                                                                                                                                    
      DATA COLOUR/1.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,                                                                                
     &   0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,                                                                                  
     &   12.0E0,12.0E0,12.0E0,12.0E0,12.0E0,12.0E0,                                                                                 
     &   4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0,                                                                                         
     &   4.0E0, 1.0E0, 1.0E0, 1.0E0, 1.0E0,                                                                                         
     &   1.0E0, 1.0E0,12.0E0, 4.0E0, 1.0E0,12.0E0/                                                                                  
      DATA SAND /15.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,                                                                                
     &   0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,                                                                                  
     &   15.0E0, 3.6E0, 1.0E0,15.0E0, 3.6E0, 1.0E0,                                                                                 
     &   15.0E0, 3.6E0, 1.0E0,15.0E0, 3.6E0,                                                                                        
     &   1.0E0,15.0E0, 3.6E0, 1.0E0,15.0E0,                                                                                         
     &   3.6E0, 1.0E0, 1.0E0, 1.0E0, 1.0E0,15.0E0/                                                                                  
      DATA CLAY / 1.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,                                                                                
     &   0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,                                                                                  
     &   1.0E0, 4.2E0,12.0E0, 1.0E0, 4.2E0,12.0E0,                                                                                  
     &   1.0E0, 4.2E0,12.0E0, 1.0E0, 4.2E0,                                                                                         
     &   12.0E0, 1.0E0, 4.2E0,12.0E0, 1.0E0, 4.2E0,                                                                                 
     &   12.0E0,12.0E0,12.0E0,12.0E0, 1.0E0/                                                                                        
      DATA DRAIN/ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,                                                                                
     &   0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,                                                                                  
     &   10.0E0,10.0E0,10.0E0, 5.0E0, 5.0E0, 5.0E0,                                                                                 
     &   10.0E0,10.0E0,10.0E0, 5.0E0, 5.0E0,                                                                                        
     &   5.0E0,10.0E0,10.0E0,10.0E0, 5.0E0, 5.0E0,                                                                                  
     &   5.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0/                                                                                         
                                                                                                                                    
      DATA     ISOIL /                                                                                                              
     .   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,                                                                            
     .   0, 331, 321, 311, 332, 322, 312, 231, 221, 211,                                                                            
     . 232, 222, 212, 131, 121, 111, 132, 122, 112, 313,                                                                            
     . 213, 113, 333 /                                                                                                              
                                                                                                                                    
      DATA NFDM/1,32,60,91,121,152,182,213,244,274,305,335,0/                                                                       
      DATA MAXX,NPGG/65341,+1/                                                                                                      
                                                                                                                                    
C---------------------------------------------------------------------                                                              
      NFF=4                                                                                                                         
      CALL JCLPNT(NFF,99,1,2,6)                                                                                                     
      REWIND 2                                                                                                                      
      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,IHYD                                                                      
      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                                                                                                                      
                                                                                                                                    
C     * DETERMINE IF IDAY IS STARTING DAY OF A MONTH. IF NOT, INCREMENT                                                             
C     * NUMBER OF MONTHS BY ONE TO INCLUDE IDAY FIELDS AS WELL FOR GC,                                                              
C     * GT AND SIC.                                                                                                                 
                                                                                                                                    
      NMO=13                                                                                                                        
      DO 125 N=1,12                                                                                                                 
        IF(IDAY.EQ.NFDM(N).AND.NMO.EQ.13) NMO=12                                                                                    
  125 CONTINUE                                                                                                                      
      IF(NMO.EQ.13) NFDM(NMO)=IDAY                                                                                                  
                                                                                                                                    
C     * INITIALIZE ACCUMULATOR OF THIRD SOIL LAYER TEMPERATURE TO 0.                                                                
                                                                                                                                    
      DO 128 I=1,LGG                                                                                                                
          GL(I)=0.E0                                                                                                                
  128 CONTINUE                                                                                                                      
                                                                                                                                    
      DO 250 N=1,NMO                                                                                                                
C---------------------------------------------------------------------                                                              
C         * GROUND COVER (LAND=-1., SEA=0., PACK ICE=1.) FOR EVERY                                                                  
C         * MONTH.                                                                                                                  
                                                                                                                                    
          NDAY = NFDM(N)                                                                                                            
          CALL GETFLD2(-1,GLL,NC4TO8("GRID"),NDAY,NC4TO8("  GC"),1,                                                                 
     +                                                IBUF,MAXX,OK)                                                                 
          IF(.NOT.OK) CALL                         XIT('INITGG6',-1)                                                                
          WRITE(6,6025) IBUF                                                                                                        
                                                                                                                                    
C         * SAVE EACH MONTH LAT-LON GROUND COVER INTO LLGC, FOR USE IN ROUTINE                                                      
C         * HRALR FOR GROUND TEMPERATURE AND SEA ICE (MUST DO FOR EACH MONTH).                                                      
                                                                                                                                    
          LLL=IBUF(5)*IBUF(6)                                                                                                       
          DO 130 I=1,LLL                                                                                                            
              LLGC(I)=GLL(I)                                                                                                        
  130     CONTINUE                                                                                                                  
          CALL HRTOLR(GC,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),2,OK,                                                              
     1                LONBAD,LATBAD)                                                                                                
          IF(.NOT.OK)THEN                                                                                                           
            WRITE(6,6030) LONBAD,LATBAD                                                                                             
            CALL LLEGG2(GC,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6))                                                                      
          ENDIF                                                                                                                     
          NPACK=MIN(4,IBUF(8))                                                                                                      
          CALL SETLAB(IBUF,NC4TO8("GRID"),NDAY,NC4TO8("  GC"),1,                                                                    
     +                                        ILG1,ILAT,0,NPACK)                                                                    
          CALL PUTFLD2(2,GC,IBUF,MAXX)                                                                                              
          WRITE(6,6026) IBUF                                                                                                        
          CALL GCROUND(GC,1,LGG)                                                                                                    
                                                                                                                                    
C------------------------------------------------------------------------                                                           
C         * GROUND TEMPERATURE (DEG K) (12 MONTHS).                                                                                 
                                                                                                                                    
          CALL GETFLD2(-1,GLL,NC4TO8("GRID"),NDAY,NC4TO8("  GT"),1,                                                                 
     +                                                IBUF,MAXX,OK)                                                                 
          IF(.NOT.OK) CALL                         XIT('INITGG6',-2)                                                                
          WRITE(6,6025) IBUF                                                                                                        
          CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                            
     1               1,OK,LONBAD,LATBAD)                                                                                            
          IF(.NOT.OK)THEN                                                                                                           
            WRITE(6,6030) LONBAD,LATBAD                                                                                             
            CALL LLIGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                               
          ENDIF                                                                                                                     
                                                                                                                                    
C         * ACCUMULATE THIRD SOIL LAYER TEMPERATURE; SET FIRST SOIL                                                                 
C         * LAYER TEMPERATURE TO GT OF STARTING DAY.                                                                                
                                                                                                                                    
          IF(N.LT.13) THEN                                                                                                          
              DO 134 I=1,LGG                                                                                                        
                  GL(I)=GL(I)+GH(I)                                                                                                 
  134         CONTINUE                                                                                                              
          ENDIF                                                                                                                     
          IF(IDAY.EQ.NFDM(N)) THEN                                                                                                  
              DO 135 I=1,LGG                                                                                                        
                  GT(I)=GH(I)                                                                                                       
  135         CONTINUE                                                                                                              
          ENDIF                                                                                                                     
                                                                                                                                    
          CALL SETLAB(IBUF,NC4TO8("GRID"),NDAY,NC4TO8("  GT"),1,                                                                    
     +                                         ILG1,ILAT,0,NPGG)                                                                    
          CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                              
          WRITE(6,6026) IBUF                                                                                                        
                                                                                                                                    
C------------------------------------------------------------------------                                                           
C         * SEA ICE AMOUNT (KG M-2) (12 MONTHS)                                                                                     
                                                                                                                                    
          CALL GETFLD2(-1,GLL,NC4TO8("GRID"),NDAY,NC4TO8(" SIC"),1,                                                                 
     +                                                IBUF,MAXX,OK)                                                                 
          IF(.NOT.OK) CALL                         XIT('INITGG6',-3)                                                                
          WRITE(6,6025) IBUF                                                                                                        
          DO 140 I=1,LLL                                                                                                            
            GWH(I)=MERGE(0.0E0,LLGC(I),LLGC(I).GE.0.0E0)                                                                            
  140     CONTINUE                                                                                                                  
          DO 145 I=1,LGG                                                                                                            
            GWL(I)=MERGE(0.0E0,GC(I),GC(I).GE.0.0E0)                                                                                
  145     CONTINUE                                                                                                                  
          CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GWL,GWH,                                                            
     1               1,OK,LONBAD,LATBAD)                                                                                            
          IF(.NOT.OK)THEN                                                                                                           
            WRITE(6,6030) LONBAD,LATBAD                                                                                             
            CALL LLEGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6))                                                                      
          ENDIF                                                                                                                     
          DO 150 I=1,LGG                                                                                                            
            GH(I)=MERGE(0.0E0,MAX(0.0E0,GH(I)),GC(I).EQ.0.0E0)                                                                      
  150     CONTINUE                                                                                                                  
          NPACK=MIN(2,IBUF(8))                                                                                                      
          CALL SETLAB(IBUF,NC4TO8("GRID"),NDAY,NC4TO8(" SIC"),1,                                                                    
     +                                        ILG1,ILAT,0,NPACK)                                                                    
          CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                              
          WRITE(6,6026) IBUF                                                                                                        
  250 CONTINUE                                                                                                                      
C---------------------------------------------------------------------                                                              
C     * CALCULATE TEMPERATURE OF SECOND SOIL LAYER; WRITE OUT ALL                                                                   
C     * THREE SOIL LAYER TEMPERATURES.                                                                                              
                                                                                                                                    
      DO 260 I=1,LGG                                                                                                                
          GL(I)=GL(I)/12.E0                                                                                                         
          GH(I)=(GT(I)+GL(I))/2.E0                                                                                                  
  260 CONTINUE                                                                                                                      
                                                                                                                                    
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("TBAR"),1,                                                                        
     +                                     ILG1,ILAT,0,NPGG)                                                                        
      CALL PUTFLD2(2,GT,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("TBAR"),2,                                                                        
     +                                     ILG1,ILAT,0,NPGG)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("TBAR"),3,                                                                        
     +                                     ILG1,ILAT,0,NPGG)                                                                        
      CALL PUTFLD2(2,GL,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * ENVELOPE OROGRAPHY (VARIANCE IN M2).                                                                                        
C     * PUT VALUES TO ZERO OVER SEA ICE AND OCEAN POINTS.                                                                           
C     * IN ORDER TO DO THIS, THE HIGH-RESOLUTION GROUND COVER FIELD FOR IDAY                                                        
C     * IS READ BACK IN AND REDUCED TO THE GAUSSIAN-GRID. BOTH OF THESE FIELDS                                                      
C     * ARE SAVED FOR LATER USE IN THE PROGRAM.                                                                                     
                                                                                                                                    
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8(" ENV"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INITGG6',-4)                                                                
      WRITE(6,6025) IBUF                                                                                                            
                                                                                                                                    
      CALL GETFLD2(-1,LLGC,NC4TO8("GRID"),IDAY,NC4TO8("  GC"),1,                                                                    
     +                                             IBUF,MAXX,OK)                                                                    
      IF(.NOT.OK) CALL                             XIT('INITGG6',-5)                                                                
      CALL HRTOLR(GC,ILG1,ILAT,DLON,DLAT,LLGC,IBUF(5),IBUF(6),2,OK,                                                                 
     1            LONBAD,LATBAD)                                                                                                    
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLEGG2(GC,ILG1,ILAT,DLAT,LLGC,IBUF(5),IBUF(6))                                                                         
      ENDIF                                                                                                                         
                                                                                                                                    
      CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                                
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                   
      ENDIF                                                                                                                         
                                                                                                                                    
      DO 270 I=1,LGG                                                                                                                
        GH(I) = MERGE(MAX(GH(I),0.0E0), 0.0E0, GC(I).LT.0.0E0)                                                                      
  270 CONTINUE                                                                                                                      
                                                                                                                                    
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8(" ENV"),1,                                                                        
     +                                     ILG1,ILAT,0,NPGG)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * SURFACE DRAG COEFFICIENT (DIMENSIONLESS).                                                                                   
C     * LN OF SURFACE ROUGHNESS LENGTH IS 1X1 INPUT FIELD.                                                                          
                                                                                                                                    
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("LNZ0"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INITGG6',-6)                                                                
      WRITE(6,6025) IBUF                                                                                                            
                                                                                                                                    
      CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                                
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK) THEN                                                                                                              
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                   
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * CONVERT TO A DRAG COEFFICIENT USING FIXED REFERENCE                                                                         
C     * HEIGHT OF 150 METRES. NOTE THAT THIS IS CORRECTED FOR                                                                       
C     * INSIDE THE GCM TO ACCOUNT FOR THE LOCAL HEIGHT OF THE                                                                       
C     * LOWEST MOMENTUM MID-LAYER POSITION.                                                                                         
C                                                                                                                                   
      VKC=0.4E0                                                                                                                     
      ALGREF=LOG(150.E0)                                                                                                            
      DO 300 I=1,LGG                                                                                                                
          DRFAC=ALGREF-GH(I)                                                                                                        
          GH(I)=(VKC/DRFAC)**2                                                                                                      
  300 CONTINUE                                                                                                                      
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("  DR"),1,                                                                        
     +                                     ILG1,ILAT,0,NPGG)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * PRIMARY VEGETATION CLASS (CLASSES 0 THROUGH 24).                                                                            
                                                                                                                                    
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("PVEG"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INITGG6',-7)                                                                
      WRITE(6,6025) IBUF                                                                                                            
      CALL HRALR(GL,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                                
     1           0,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLEGG2(GL,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6))                                                                          
      ENDIF                                                                                                                         
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("PVEG"),1,                                                                        
     +                                        ILG1,ILAT,0,1)                                                                        
      CALL PUTFLD2(2,GL,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * SNOW DEPTH (KG/M**2 WATER EQUIVALENT = MM SNOW).                                                                            
C     * MAKE SURE SNOW IS NOT NEGATIVE, AND IS 0. OVER WATER.                                                                       
C     * SELECT DAY IDAY ONLY.                                                                                                       
                                                                                                                                    
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),IDAY,NC4TO8(" SNO"),1,                                                                     
     +                                            IBUF,MAXX,OK)                                                                     
      IF(.NOT.OK) GO TO 535                                                                                                         
      WRITE(6,6025) IBUF                                                                                                            
      CALL HRTOLR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),                                                                       
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                   
      ENDIF                                                                                                                         
      DO 400 I=1,LGG                                                                                                                
        GH(I)=MERGE(0.0E0,MAX(0.0E0,GH(I)),GC(I).EQ.0.0E0)                                                                          
  400 CONTINUE                                                                                                                      
      NPACK=MIN(2,IBUF(8))                                                                                                          
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8(" SNO"),1,                                                                        
     +                                    ILG1,ILAT,0,NPACK)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * FROZEN WATER (FRACTION OF SOIL CAPACITY).                                                                                   
C     * IT MUST LIE BETWEEN 0. AND 1, AND BE 0.,1. OVER SEA,ICE.                                                                    
C     * SELECT DAY IDAY ONLY.                                                                                                       
                                                                                                                                    
  535 CALL GETFLD2(-1,GLL,NC4TO8("GRID"),IDAY,NC4TO8("  WF"),1,                                                                     
     +                                            IBUF,MAXX,OK)                                                                     
      IF(.NOT.OK) GO TO 545                                                                                                         
      WRITE(6,6025) IBUF                                                                                                            
      CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                                
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                   
      ENDIF                                                                                                                         
      DO 540 I=1,LGG                                                                                                                
        GH(I) = MAX (MIN (GH(I), 1.0E0), 0.0E0)                                                                                     
        GH(I) = MERGE(1.0E0, GH(I), GC(I).EQ.1.0E0)                                                                                 
        GH(I) = MERGE(0.0E0, GH(I), GC(I).EQ.0.0E0)                                                                                 
        GH(I) = MERGE(1.0E0, GH(I), GL(I).EQ.1.0E0)                                                                                 
  540 CONTINUE                                                                                                                      
                                                                                                                                    
      NPACK=MIN(4,IBUF(8))                                                                                                          
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("  WF"),1,                                                                        
     +                                    ILG1,ILAT,0,NPACK)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * LIQUID WATER (FRACTION OF SOIL CAPACITY).                                                                                   
C     * IT MUST LIE BETWEEN 0. AND 1, AND BE 1.,0. OVER SEA,ICE.                                                                    
C     * SELECT DAY IDAY ONLY.                                                                                                       
                                                                                                                                    
  545 CALL GETFLD2(-1,GLL,NC4TO8("GRID"),IDAY,NC4TO8("  WL"),1,                                                                     
     +                                            IBUF,MAXX,OK)                                                                     
      IF(.NOT.OK) GO TO 555                                                                                                         
      WRITE(6,6025) IBUF                                                                                                            
      CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                                
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                   
      ENDIF                                                                                                                         
      DO 550 I=1,LGG                                                                                                                
        GH(I) = MAX (MIN (GH(I), 1.0E0), 0.0E0)                                                                                     
        GH(I) = MERGE(0.0E0, GH(I), GC(I).EQ.1.0E0)                                                                                 
        GH(I) = MERGE(1.0E0, GH(I), GC(I).EQ.0.0E0)                                                                                 
        GH(I) = MERGE(0.0E0, GH(I), GL(I).EQ.1.0E0)                                                                                 
  550 CONTINUE                                                                                                                      
      NPACK=MIN(4,IBUF(8))                                                                                                          
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("  WL"),1,                                                                        
     +                                    ILG1,ILAT,0,NPACK)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * SECONDARY VEGETATION CLASS (CLASSES 0 THROUGH 24).                                                                          
                                                                                                                                    
  555 CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("SVEG"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INITGG6',-8)                                                                
      WRITE(6,6025) IBUF                                                                                                            
      CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                                
     1           0,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLEGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6))                                                                          
      ENDIF                                                                                                                         
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("SVEG"),1,                                                                        
     +                                        ILG1,ILAT,0,1)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * SOIL (CLASSES 11 THROUGH 32).                                                                                               
C     * ENSURE CONSISTENCY WITH PRIMARY VEGETATION FIELD OVER GLACIER                                                               
C     * ICE AND WITH GROUND COVER OVER OTHER NON-LAND POINTS.                                                                       
C                                                                                                                                   
      IF(IHYD.LT.2) THEN                                                                                                            
                                                                                                                                    
C     * VERSIONS 1 AND 2 OF LAND SURFACE SCHEME ----------------------                                                              
                                                                                                                                    
          CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("SOIL"),1,                                                                    
     +                                             IBUF,MAXX,OK)                                                                    
          IF(.NOT.OK) CALL                         XIT('INITGG6',-9)                                                                
          WRITE(6,6025) IBUF                                                                                                        
C                                                                                                                                   
C     * CLEAR THE LO-RES OUTPUT FIELD - SET IT TO 9 SO THAT ALL SOILS                                                               
C     * WILL BE DISTINGUISHABLE FROM WATER (0) AND GLACIER ICE (32)                                                                 
C                                                                                                                                   
          DO 560 I = 1, LGG                                                                                                         
  560     GH(I)    = 9.0E0                                                                                                          
C                                                                                                                                   
C     * CONSTRUCT LO-RES COLOUR, TEXTURE AND DRAINAGE FIELDS IN TURN                                                                
C     * AND ADD THEM TO THE LO-RES OUTPUT FIELD. EACH LO-RES PROPERTY                                                               
C     * IS ON A SCALE FROM 0 TO 9 AND IS LEFT-SHIFTED SO THAT THE                                                                   
C     * TEN-THOUSANDS DIGIT REPRESENTS COLOUR, THE THOUSANDS DIGIT                                                                  
C     * TEXTURE AND THE HUNDREDS DIGIT DRAINAGE. CODES 0 AND 32 STILL                                                               
C     * REPRESENT WATER AND GLACIER ICE RESPECTIVELY.                                                                               
C                                                                                                                                   
          DO 585 K = 1, 3                                                                                                           
          KP       = 10**(5-K)                                                                                                      
C                                                                                                                                   
C     * LOAD HI-RES PROPERTY FIELD INTO HI-RES WORKSPACE.                                                                           
C                                                                                                                                   
          IF(K.EQ.1) THEN                                                                                                           
              DO 565 I = 1,LLL                                                                                                      
                  IS     = ISOIL(INT(GLL(I)))                                                                                       
                  GWH(I) = FLOAT(IS/100)                                                                                            
  565         CONTINUE                                                                                                              
          ELSE IF(K.EQ.2) THEN                                                                                                      
              DO 570 I = 1,LLL                                                                                                      
                  IS     = ISOIL(INT(GLL(I)))                                                                                       
                  IPROP1 = IS/100                                                                                                   
                  GWH(I) = FLOAT((IS-100*IPROP1)/10)                                                                                
  570         CONTINUE                                                                                                              
          ELSE IF(K.EQ.3) THEN                                                                                                      
              DO 575 I = 1,LLL                                                                                                      
                  IS     = ISOIL(INT(GLL(I)))                                                                                       
                  IPROP1 = IS/100                                                                                                   
                  IPROP2 = (IS-100*IPROP1)/10                                                                                       
                  GWH(I) = FLOAT(IS - 100*IPROP1 - 10*IPROP2)                                                                       
  575         CONTINUE                                                                                                              
          ENDIF                                                                                                                     
C                                                                                                                                   
C     * CONSTRUCT LO-RES PROPERTY FIELD IN LO-RES WORKSPACE; IT WILL                                                                
C     * CONSIST OF AVERAGES IN THE INCLUSIVE RANGE 1.0-3.0                                                                          
C                                                                                                                                   
          CALL HRALR(GWL,ILG1,ILAT,DLON,DLAT,GWH,IBUF(5),IBUF(6),GC,                                                                
     1               LLGC,1,OK,LONBAD,LATBAD)                                                                                       
          IF( .NOT.OK ) THEN                                                                                                        
             WRITE(6,6030) LONBAD, LATBAD                                                                                           
             CALL LLIGG2(GWL,ILG1,ILAT,DLAT,GWH,IBUF(5),IBUF(6),INTERP)                                                             
          END IF                                                                                                                    
C                                                                                                                                   
C     * ADD LO-RES PROPERTY FIELD TO LO-RES OUTPUT FIELD. NOTE THAT                                                                 
C     * CODE 25 (DARK,FINE,FREE) COMES OUT AS 00009 AND IS THEREFORE                                                                
C     * INDISTINGUISHABLE FROM WATER EXCEPT BY ITS UNITS DIGIT.                                                                     
C     * ABORT IF LO-RES PROPERTY FIELD LESS THAN ONE (INVALID RESULT),                                                              
C     * APART FROM VERY SMALL ROUND-OFF ERROR DUE TO AVERAGING SUBROUTINE                                                           
C     * WHEN ALL HIGH-RESOLUTION VALUES IN THE LOW-RESOLUTION GRID SQUARE                                                           
C     * HAVE THE SAME VALUE.                                                                                                        
C                                                                                                                                   
          DO 580 I = 1, LGG                                                                                                         
              IF(GC(I).GT.-0.5E0) THEN                                                                                              
                  GH(I)=0.E0                                                                                                        
              ELSE IF(GL(I).EQ.1.E0) THEN                                                                                           
                  GH(I)=32.E0                                                                                                       
              ELSE IF(GWL(I).LT.0.99999E0) THEN                                                                                     
                  WRITE(6,6040) I,K,GWL(I)                                                                                          
                  CALL                             XIT('INITGG6',-10)                                                               
              ELSE                                                                                                                  
                  GWL(I)   = MAX(GWL(I),1.E0)                                                                                       
                  GH(I) = GH(I) +                                                                                                   
     &              FLOAT(KP*MIN(9,INT(5.0E0*GWL(I))-5))                                                                            
              ENDIF                                                                                                                 
  580     CONTINUE                                                                                                                  
                                                                                                                                    
  585     CONTINUE                                                                                                                  
                                                                                                                                    
          CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("SOIL"),1,                                                                    
     +                                            ILG1,ILAT,0,1)                                                                    
          CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                              
          WRITE(6,6026) IBUF                                                                                                        
                                                                                                                                    
      ELSE                                                                                                                          
                                                                                                                                    
C     * CLASS - CANADIAN LAND SURFACE SCHEME -------------------------                                                              
                                                                                                                                    
          CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("SOIL"),1,                                                                    
     +                                             IBUF,MAXX,OK)                                                                    
          IF(.NOT.OK) CALL                         XIT('INITGG6',-9)                                                                
          WRITE(6,6025) IBUF                                                                                                        
C                                                                                                                                   
C     * INITIALIZE THE LOW-RESOLUTION OUTPUT FIELD TO ZERO.                                                                         
C                                                                                                                                   
          DO 590 I = 1, LGG                                                                                                         
              GH(I) = 0.0E0                                                                                                         
  590     CONTINUE                                                                                                                  
C                                                                                                                                   
C     * PRODUCE LOW-RESOLUTION COLOUR, SANDINESS, CLAYINESS AND DRAINAGE                                                            
C     * FIELDS IN TURN AND CONCATENATE THEM INTO THE LOW-RESOLUTION                                                                 
C     * OUTPUT FIELD.                                                                                                               
C                                                                                                                                   
          DO 620 K = 1, 4                                                                                                           
          KP       = 10**(2*(4-K))                                                                                                  
C                                                                                                                                   
C     * LOAD HIGH-RES PROPERTY FIELD INTO HIGH-RES WORKSPACE.                                                                       
C                                                                                                                                   
          IF(K.EQ.1) THEN                                                                                                           
              DO 595 I = 1,LLL                                                                                                      
                  GWH(I) = COLOUR(INT(GLL(I)))                                                                                      
  595         CONTINUE                                                                                                              
          ELSEIF(K.EQ.2) THEN                                                                                                       
              DO 600 I = 1,LLL                                                                                                      
                  GWH(I) = SAND(INT(GLL(I)))                                                                                        
  600         CONTINUE                                                                                                              
          ELSEIF(K.EQ.3) THEN                                                                                                       
              DO 605 I = 1,LLL                                                                                                      
                  GWH(I) = CLAY(INT(GLL(I)))                                                                                        
  605         CONTINUE                                                                                                              
          ELSEIF(K.EQ.4) THEN                                                                                                       
              DO 610 I = 1,LLL                                                                                                      
                  GWH(I) = DRAIN(INT(GLL(I)))                                                                                       
  610         CONTINUE                                                                                                              
          ENDIF                                                                                                                     
C                                                                                                                                   
C     * CONSTRUCT LOW-RES PROPERTY FIELD IN LOW-RES WORKSPACE.                                                                      
C                                                                                                                                   
          CALL HRALR(GWL,ILG1,ILAT,DLON,DLAT,GWH,IBUF(5),IBUF(6),GC,                                                                
     1               LLGC,1,OK,LONBAD,LATBAD)                                                                                       
          IF( .NOT.OK ) THEN                                                                                                        
             WRITE(6,6030) LONBAD, LATBAD                                                                                           
             CALL LLIGG2(GWL,ILG1,ILAT,DLAT,GWH,IBUF(5),IBUF(6),INTERP)                                                             
          END IF                                                                                                                    
C                                                                                                                                   
C     * ADD LOW-RES PROPERTY FIELD TO LOW-RES OUTPUT FIELD.                                                                         
C     * ABORT IF LOW-RES PROPERTY FIELD LESS THAN ONE (INVALID RESULT),                                                             
C     * APART FROM VERY SMALL ROUND-OFF ERROR DUE TO AVERAGING SUBROUTINE                                                           
C     * WHEN ALL HIGH-RESOLUTION VALUES IN THE LOW-RESOLUTION GRID SQUARE                                                           
C     * HAVE THE SAME VALUE.                                                                                                        
C                                                                                                                                   
          DO 615 I = 1, LGG                                                                                                         
              IF(GC(I).GT.-0.5E0) THEN                                                                                              
                  GH(I)=0.E0                                                                                                        
              ELSE IF(GL(I).EQ.1.E0) THEN                                                                                           
                  GH(I)=32160100.E0                                                                                                 
              ELSE                                                                                                                  
                  GH(I)    = GH(I) + FLOAT(KP*NINT(GWL(I)))                                                                         
              ENDIF                                                                                                                 
  615     CONTINUE                                                                                                                  
                                                                                                                                    
  620     CONTINUE                                                                                                                  
                                                                                                                                    
          CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("SOIL"),1,                                                                    
     +                                            ILG1,ILAT,0,1)                                                                    
          CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                              
          WRITE(6,6026) IBUF                                                                                                        
                                                                                                                                    
      ENDIF                                                                                                                         
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * AREAL PERCENTAGE OF BARE SOIL.                                                                                              
C     * ENSURE CONSISTENCY WITH PRIMARY VEGETATION FIELD OVER GLACIER                                                               
C     * ICE AND WITH GROUND COVER OVER OTHER NON-LAND POINTS.                                                                       
                                                                                                                                    
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("PGND"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INITGG6',-11)                                                               
      WRITE(6,6025) IBUF                                                                                                            
      CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                                
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                   
      ENDIF                                                                                                                         
      DO 625 I=1,LGG                                                                                                                
          IF(GL(I).EQ.1.E0.OR.GC(I).GT.-0.5E0) GH(I)= 0.E0                                                                          
  625 CONTINUE                                                                                                                      
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("PGND"),1,                                                                        
     +                                        ILG1,ILAT,0,1)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * AREAL PERCENTAGE OF TALL CANOPY.                                                                                            
C     * ENSURE CONSISTENCY WITH PRIMARY VEGETATION FIELD OVER GLACIER                                                               
C     * ICE AND WITH GROUND COVER OVER OTHER NON-LAND POINTS.                                                                       
                                                                                                                                    
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8(" FCT"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INITGG6',-12)                                                               
      WRITE(6,6025) IBUF                                                                                                            
      CALL HRALR(GWL,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                               
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK) THEN                                                                                                              
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GWL,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                  
      ENDIF                                                                                                                         
      DO 630 I=1,LGG                                                                                                                
          IF(GL(I).EQ.1.E0.OR.GC(I).GT.-0.5E0) GWL(I)= 0.E0                                                                         
  630 CONTINUE                                                                                                                      
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("FCAN"),1,                                                                        
     +                                        ILG1,ILAT,0,1)                                                                        
      CALL PUTFLD2(2,GWL,IBUF,MAXX)                                                                                                 
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * VISIBLE ALBEDO OF TALL CANOPY.                                                                                              
C     * CONVERT FROM PERCENT TO FRACTION AND COMPLETE WEIGHTING                                                                     
C     * CALCULATION OVER CANOPY TYPES.                                                                                              
                                                                                                                                    
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("AVTW"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INITGG6',-13)                                                               
      WRITE(6,6025) IBUF                                                                                                            
                                                                                                                                    
      CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                                
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK) THEN                                                                                                              
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                   
      ENDIF                                                                                                                         
      DO 635 I=1,LGG                                                                                                                
          IF(GWL(I).GT.0.0E0) THEN                                                                                                  
              GH(I) = 0.01E0*GH(I)/GWL(I)                                                                                           
          ELSE                                                                                                                      
              GH(I)=0.0E0                                                                                                           
          ENDIF                                                                                                                     
  635 CONTINUE                                                                                                                      
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("ALVC"),1,                                                                        
     +                                     ILG1,ILAT,0,NPGG)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * NEAR-IR ALBEDO OF TALL CANOPY.                                                                                              
C     * CONVERT FROM PERCENT TO FRACTION AND COMPLETE WEIGHTING                                                                     
C     * CALCULATION OVER CANOPY TYPES.                                                                                              
                                                                                                                                    
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("AITW"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INITGG6',-14)                                                               
      WRITE(6,6025) IBUF                                                                                                            
                                                                                                                                    
      CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                                
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK) THEN                                                                                                              
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                   
      ENDIF                                                                                                                         
      DO 640 I=1,LGG                                                                                                                
          IF(GWL(I).GT.0.0E0) THEN                                                                                                  
              GH(I) = 0.01E0*GH(I)/GWL(I)                                                                                           
          ELSE                                                                                                                      
              GH(I)=0.0E0                                                                                                           
          ENDIF                                                                                                                     
  640 CONTINUE                                                                                                                      
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("ALIC"),1,                                                                        
     +                                     ILG1,ILAT,0,NPGG)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * AREAL PERCENTAGE OF SHORT CANOPY.                                                                                           
C     * ENSURE CONSISTENCY WITH PRIMARY VEGETATION FIELD OVER GLACIER                                                               
C     * ICE AND WITH GROUND COVER OVER OTHER NON-LAND POINTS.                                                                       
                                                                                                                                    
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8(" FCS"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INITGG6',-15)                                                               
      WRITE(6,6025) IBUF                                                                                                            
      CALL HRALR(GWL,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                               
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK) THEN                                                                                                              
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GWL,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                  
      ENDIF                                                                                                                         
      DO 645 I=1,LGG                                                                                                                
          IF(GL(I).EQ.1.E0.OR.GC(I).GT.-0.5E0) GWL(I)= 0.E0                                                                         
  645 CONTINUE                                                                                                                      
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("FCAN"),2,                                                                        
     +                                        ILG1,ILAT,0,1)                                                                        
      CALL PUTFLD2(2,GWL,IBUF,MAXX)                                                                                                 
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * VISIBLE ALBEDO OF SHORT CANOPY.                                                                                             
C     * CONVERT FROM PERCENT TO FRACTION AND COMPLETE WEIGHTING                                                                     
C     * CALCULATION OVER CANOPY TYPES.                                                                                              
                                                                                                                                    
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("AVSW"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INITGG6',-16)                                                               
      WRITE(6,6025) IBUF                                                                                                            
                                                                                                                                    
      CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                                
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK) THEN                                                                                                              
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                   
      ENDIF                                                                                                                         
      DO 650 I=1,LGG                                                                                                                
          IF(GWL(I).GT.0.0E0) THEN                                                                                                  
              GH(I) = 0.01E0*GH(I)/GWL(I)                                                                                           
          ELSE                                                                                                                      
              GH(I)=0.0E0                                                                                                           
          ENDIF                                                                                                                     
  650 CONTINUE                                                                                                                      
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("ALVC"),2,                                                                        
     +                                     ILG1,ILAT,0,NPGG)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * NEAR-IR ALBEDO OF SHORT CANOPY.                                                                                             
C     * CONVERT FROM PERCENT TO FRACTION AND COMPLETE WEIGHTING                                                                     
C     * CALCULATION OVER CANOPY TYPES.                                                                                              
                                                                                                                                    
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("AISW"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INITGG6',-17)                                                               
      WRITE(6,6025) IBUF                                                                                                            
                                                                                                                                    
      CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                                
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK) THEN                                                                                                              
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                   
      ENDIF                                                                                                                         
      DO 655 I=1,LGG                                                                                                                
          IF(GWL(I).GT.0.0E0) THEN                                                                                                  
              GH(I) = 0.01E0*GH(I)/GWL(I)                                                                                           
          ELSE                                                                                                                      
              GH(I)=0.0E0                                                                                                           
          ENDIF                                                                                                                     
  655 CONTINUE                                                                                                                      
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("ALIC"),2,                                                                        
     +                                     ILG1,ILAT,0,NPGG)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * ALBEDO (CONVERT FROM PER-CENT TO FRACTION 0. TO 1.)                                                                         
                                                                                                                                    
      CALL GETFLD2(-1,GL,NC4TO8("GRID"),0,NC4TO8("  AL"),1,IBUF,MAXX,OK)                                                            
      IF(.NOT.OK) CALL                             XIT('INITGG6',-18)                                                               
      WRITE(6,6025) IBUF                                                                                                            
                                                                                                                                    
      CALL LLIGG2(GH,ILG1,ILAT,DLAT,GL,IBUF(5),IBUF(6),INTERP)                                                                      
      DO 660 I=1,LGG                                                                                                                
        GH(I) = GH(I)*0.01E0                                                                                                        
        GH(I) = MAX (MIN (GH(I), 1.0E0), 0.0E0)                                                                                     
  660 CONTINUE                                                                                                                      
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("  AL"),1,                                                                        
     +                                     ILG1,ILAT,0,NPGG)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * VISIBLE ALBEDO (CONVERT FROM PER-CENT TO FRACTION 0. TO 1.)                                                                 
                                                                                                                                    
C     * FIRST CONVERT HIGH AND LOW RESOLUTION GROUND COVERS TO LAND/                                                                
C     * NO-LAND MASK, SINCE SEA-ICE ALBEDO CALCULATION DONE INSIDE                                                                  
C     * MODEL (LAND:GC=1., NO-LAND:GC=0.)                                                                                           
C                                                                                                                                   
      DO 670 I=1,LLL                                                                                                                
          IF(LLGC(I).GE.0.E0) THEN                                                                                                  
              LLGC(I)=0.E0                                                                                                          
          ELSE                                                                                                                      
              LLGC(I)=1.E0                                                                                                          
          ENDIF                                                                                                                     
  670 CONTINUE                                                                                                                      
                                                                                                                                    
      DO 680 I=1,LGG                                                                                                                
          IF(GC(I).GE.0.E0) THEN                                                                                                    
              GC(I)=0.E0                                                                                                            
          ELSE                                                                                                                      
              GC(I)=1.E0                                                                                                            
          ENDIF                                                                                                                     
  680 CONTINUE                                                                                                                      
                                                                                                                                    
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("ALSW"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INITGG6',-19)                                                               
      WRITE(6,6025) IBUF                                                                                                            
C                                                                                                                                   
C     * FIRST BOGUS IN VALUE OF 999 FOR LLGC FOR HIGH-RESOLUTION POINTS                                                             
C     * HAVING ZERO VALUE. THESE ARE LAND POINTS WHICH ARE TOTALLY                                                                  
C     * BARE SOIL I.E. DESERT) AND THE AVERAGING FOR CANOPY ALBEDO (BOTH                                                            
C     * VISIBLE AND NEAR-IR) SHOULD NOT INCLUDE THEM.                                                                               
C                                                                                                                                   
      DO 690 I=1,LLL                                                                                                                
          IF(GLL(I).EQ.0.E0) LLGC(I)=999.E0                                                                                         
  690 CONTINUE                                                                                                                      
                                                                                                                                    
      CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                                
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                   
      ENDIF                                                                                                                         
      DO 700 I=1,LGG                                                                                                                
        GH(I) = GH(I)*0.01E0                                                                                                        
  700 CONTINUE                                                                                                                      
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("ALSW"),1,                                                                        
     +                                     ILG1,ILAT,0,NPGG)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * NEAR-IR ALBEDO (CONVERT FROM PERCENT TO FRACTION 0. TO 1.)                                                                  
                                                                                                                                    
      CALL GETFLD2(-1,GLL,NC4TO8("GRID"),0,NC4TO8("ALLW"),1,                                                                        
     +                                         IBUF,MAXX,OK)                                                                        
      IF(.NOT.OK) CALL                             XIT('INITGG6',-20)                                                               
      WRITE(6,6025) IBUF                                                                                                            
                                                                                                                                    
      CALL HRALR(GH,ILG1,ILAT,DLON,DLAT,GLL,IBUF(5),IBUF(6),GC,LLGC,                                                                
     1           1,OK,LONBAD,LATBAD)                                                                                                
      IF(.NOT.OK) THEN                                                                                                              
        WRITE(6,6030) LONBAD,LATBAD                                                                                                 
        CALL LLIGG2(GH,ILG1,ILAT,DLAT,GLL,IBUF(5),IBUF(6),INTERP)                                                                   
      ENDIF                                                                                                                         
      DO 710 I=1,LGG                                                                                                                
          GH(I) = GH(I)*0.01E0                                                                                                      
  710 CONTINUE                                                                                                                      
      CALL SETLAB(IBUF,NC4TO8("GRID"),IDAY,NC4TO8("ALLW"),1,                                                                        
     +                                     ILG1,ILAT,0,NPGG)                                                                        
      CALL PUTFLD2(2,GH,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C---------------------------------------------------------------------                                                              
C     * SURFACE HEIGHT (FROM CONTROL FILE).                                                                                         
C     * CONVERT BACK TO HEIGHT IN METRES FOR DISPLAY PURPOSES.                                                                      
C     * ELIMINATE ANY NEGATIVE VALUES WHICH OCCURRED DUE TO SMOOTHING.                                                              
                                                                                                                                    
      CALL GETFLD2(99,GL,NC4TO8("GRID"),0,NC4TO8("PHIS"),1,IBUF,MAXX,OK)                                                            
      IF(.NOT.OK) CALL                             XIT('INITGG6',-22)                                                               
      WRITE(6,6025) IBUF                                                                                                            
      LG=IBUF(5)*IBUF(6)                                                                                                            
      DO 720 I=1,LG                                                                                                                 
        GL(I)=GL(I)/9.80616E0                                                                                                       
        GL(I) = MAX (GL(I), 0.0E0)                                                                                                  
  720 CONTINUE                                                                                                                      
      IBUF(2)=IDAY                                                                                                                  
      IBUF(3)=NC4TO8("  ZS")                                                                                                        
      IBUF(8)=1                                                                                                                     
      CALL PUTFLD2(2,GL,IBUF,MAXX)                                                                                                  
      WRITE(6,6026) IBUF                                                                                                            
                                                                                                                                    
C     * E.O.F. ON FILE LL.                                                                                                          
                                                                                                                                    
      CALL                                         XIT('INITGG6',0)                                                                 
                                                                                                                                    
C     * E.O.F. ON FILE ICTL.                                                                                                        
                                                                                                                                    
  910 CALL                                         XIT('INITGG6',-23)                                                               
  911 CALL                                         XIT('INITGG6',-24)                                                               
C---------------------------------------------------------------------                                                              
 6010 FORMAT('0IDAY,ILG1,ILAT =',3I6)                                                                                               
 6025 FORMAT(' ',A4,I10,1X,A4,I10,4I6)                                                                                              
 6026 FORMAT(' ',60X,A4,I10,1X,A4,I10,4I6)                                                                                          
 6030 FORMAT('0NO POINTS FOUND WITHIN GRID SQUARE CENTRED AT (',I3,',',                                                             
     1       I3,')')                                                                                                                
 6040 FORMAT('0AT I= ',I5,', FOR IPROP= ',I1,', GWL(I)= ',E20.13)                                                                   
      END                                                                                                                           
