C**********************************************************                  INISURF.2     
C             SUBROUTINE INISURF                                             INISURF.3     
C**********************************************************                  INISURF.4     
      subroutine INISURF                                                     INISURF.5     
C-----------------------------------------------------------------------     INISURF.6     
C     Subroutine to initialise the surface model from history on channel     INISURF.7     
C     18.                                                                    INISURF.8     
C-----------------------------------------------------------------------     INISURF.9     
C                                                                            PARAM1.2     
C     Determines model resolution                                            PARAM1.3     
C                                                                            PARAM1.4     
      PARAMETER(NN=21,MM=21,NHEM=2,NL=5,MOCT=1,MG=64,JG=16,NWJ2=121          NETCDF.35    
     P         ,NCRAY=64,JGL=JG,NTRAC=1,NLEVRF=1)                            NETCDF.36    
                                                                             PARAM1.7     
C                                                                            PARAM1.8     
C                                                                            PARAM2.2     
C     Sets basic constants, especially those needed for array dimensions     PARAM2.3     
C                                                                            PARAM2.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.0*PI                             PARAM2.5     
     +,NNP=NN+1,MGPP=MG+2,JGP=JG+1,JGG=JG*NHEM,JGGP=JGG+1,MJP=NWJ2+NWJ2      PARAM2.6     
     +,NLM=NL-1,NLP=NL+1,NLPP=NL+2,NLA=NL+3,NLB=NL+4,NL2=NL*NL               PARAM2.7     
     +,IDA=(MG+MG+MG)/2+1,IDB=NWJ2*NL,IDC=IDB+IDB,IDD=MGPP*NL                PARAM2.8     
     +,IDE=NL2*NN,IDF=NCRAY*(MG+1),IDG=JG*NL,IDH=JG*MG                       PARAM2.9     
     +,IDI=NNP/2,IDJ=IDI*IDI,IDK=NL*IDI,IDL=MGPP/2,IDM=NNP/2,IDN=IDM*NL      PARAM2.10    
     +,NWW=1+(MM-1)/MOCT)                                                    PARAM2.11    
      PARAMETER(IGA=NWJ2*NHEM,IGB=IDB*NHEM,IGC=MGPP*NHEM,IGD=IDD*NHEM        PARAM2.12    
     +,IGG=IDG*NHEM,IGL=IDL*NHEM,IGM=IDM*NHEM,IGN=IDN*NHEM                   PARAM2.13    
     +,IGO=IGA+IGA,IGP=IGB+IGB,NFTWG=(5+NTRAC)*NL+3                          PARAM2.14    
     +,NFTGW=(6+3*NTRAC)*NL+2,NFTGD=(3+NTRAC)*NL,NLTR=NL*NTRAC)              PARAM2.15    
C     Number of 2D (surface) output fields. This value is                    PARAM2.16    
C     Doubled due to averaged and instantaneous fields.                      PARAM2.17    
      PARAMETER (N2DFLD=21,NGRPAD=N2DFLD*2*IGC)                              PARAM2.18    
C                                                                            PARAM2.19    
C                                                                            BLANK.2     
C     Basic planetary parameters for run plus information about              BLANK.3     
C     vertical grid structure                                                BLANK.4     
C                                                                            BLANK.5     
C     Note that RD and GASCON are identical and CPD is set from RD,AKAP.     BLANK.6     
      COMMON        SQ(NNP),RSQ(NNP),SIGMAH(NLM),SIGMA(NL)                   BLANK.7     
     +              ,T01S2(NLM),T0(NL),ALPHA(NL),DSIGMA(NL),RDSIG(NL)        BLANK.8     
     +              ,TKP(NL),C(NL2),SQH(NNP)                                 BLANK.9     
     +              ,MF,MFP,JZF,NF,NFP                                       BLANK.10    
     +              ,AKAP,GA,GASCON,RADEA,WW,P0,PFAC,EZ,AIOCT                BLANK.11    
     +              ,RD,RV,CPD,CLATNT                                        BLANK.12    
     +              ,LRSTRT,LSHORT,LTVEC,LSTRETCH                            BLANK.13    
     +              ,LFLUX                                                   BLANK.14    
     +              ,LBALAN,LRESTIJ                                          BLANK.15    
     +              ,LCLIM, LPERPET, L22L,LOROG ,LCSFCT                      BLANK.16    
     +              ,LNOISE                                                  BLANK.17    
      COMPLEX EZ,AIOCT                                                       BLANK.18    
      LOGICAL LRSTRT,LSHORT,LTVEC,LSTRETCH,LBALAN,LRESTIJ                    BLANK.19    
     +       ,LFLUX,LNOISE                                                   BLANK.20    
     +       ,LCLIM, LPERPET, L22L,LOROG,LCSFCT                              BLANK.21    
C                                                                            BLANK.22    
C                                                                            BATS.2     
C     Constant arrays and variables associated with time and vertical        BATS.3     
C     differencing. Also counters.                                           BATS.4     
C                                                                            BATS.5     
      COMMON/BATS/  BM1(IDE),AK(NNP),AQ(NL2),G(NL2),TAU(NL2)                 BATS.6     
     +              ,KOUNT,KITS,KSTART,KTOTAL,KRUN,BEGDAY,ITSPD              BATS.7     
     +              ,DELT,DELT2,CV,CG,CT,CQ,PNU,PNU2,PNU21                   BATS.8     
     +              ,NTRACO,CTRA(NTRAC),KOLOUR(NTRAC),RGG(NL2)               BATS.9     
     +              ,BEGDOY,DOY                                              BATS.10    
C                                                                            BATS.11    
C                                                                            GRIDPP.2     
C     Array ordering in GRIDP must correspond to that in SPECTR.             GRIDPP.3     
C     Real arrays: multi-level arrays are 2-dimensional.                     GRIDPP.4     
C     the variables have been renamed to coincide with                       GRIDPP.5     
C     variable names in bgcm5 DGRMLT                                         GRIDPP.6     
C                                                                            GRIDPP.7     
C swapped round VLNG and UNLG to check                                       GRIDPP.8     
      COMMON/GRIDP/ CHIG(IGC,NL),SFG(IGC,NL),UG(IGC,NL),VG(IGC,NL)           GRIDPP.9     
     :              ,TTVD(IGC,NL),QTVD(IGC,NL),TG(IGC,NL)                    GRIDPP.10    
     :              ,TRAG(IGC,NL,NTRAC)                                      GRIDPP.11    
     :              ,PLG(IGC),TYBL(IGC),TXBL(IGC)                            GRIDPP.12    
     :              ,SPG(IGC),VPG(IGC),TTRD(IGC,NL)                          GRIDPP.13    
     :              ,TNLG(IGC,NL),TRANLG(IGC,NL,NTRAC),UNLG(IGC,NL)          GRIDPP.14    
     :              ,VNLG(IGC,NL),TTLR(IGC,NL),UTRAG(IGC,NL,NTRAC)           GRIDPP.15    
     :              ,TTCR(IGC,NL),VTRAG(IGC,NL,NTRAC)                        GRIDPP.16    
     :              ,UTVD(IGC,NL),VTVD(IGC,NL)                               GRIDPP.17    
     :         ,ASSBL(IGC),ASHBL(IGC),ASLBL(IGC),ARRCR(IGC),ARRLR(IGC)       GRIDPP.18    
     :         ,arflux(igc,6),asfld(igc,6),acld(igc,4)                       GRIDPP.19    
     :         ,SSBL(IGC),SHBL(IGC),SLBL(IGC),RRCR(IGC),RRLR(IGC)            GRIDPP.20    
     :         ,rflux(igc,6),sfld(igc,6),cld(igc,4)                          GRIDPP.21    
C                                                                            GRIDPP.22    
      COMMON/PHYS/  LBL,LVD,LCR,LLR,LRD,LCUBM,LCBADJ                         PHYSCA.2     
     :              ,TSTAR(IGC,JG),QSTAR(IGC,JG),FRAD(JG,NHEM)               PHYSCA.3     
     :              ,TSTARO(IGC,JG),TDEEPO(IGC,JG),smstar(igc,jg)            PHYSCA.4     
     :              ,tdeep(igc,jg),hsnow(igc,jg),sqstar(igc,jg)              PHYSCA.5     
     :              ,SALB(IGC,JG),SBAL(IGC,JG),BLCD(IGC)                     PHYSCA.6     
     :              ,SVEGE(IGC,JG),CD,DRAG,BLVAD,BLA,BLRH,BLVB(IGC)          PHYSCA.7     
     :              ,AKVV,AKTV,AKQV,ESCONA,ESCONB,EPSIQ,CTQ,CCC              PHYSCA.8     
     : ,ctqi,sdsn,shcs,shcsp,shcsn,skse,sksn,slhf,sd1,sd2,sdw                PHYSCA.9     
     :        ,ssmc,sdsnd,LSL,sasnow,saice,shsstar,shsmax                    PHYSCA.10    
     :     ,LOC,SHCO,SHCI,LNOICE,LOLDBL,LCOND,LNNSK,ITSLL,ITSLO              PHYSCA.11    
     :              ,CCR,RCON,DTBUOY,TSLA,TSLB,TSLC,TSLD,CUT1,CUT2           PHYSCA.12    
     :              ,NLCR,NCUTOP,CURHM,AKTC,AKQC,CUBMT,CBADJT,CBADJP         PHYSCA.13    
     :              ,SKAP(NL),SK(NLM),FWS(NL),CLR(NL),FB(NLM)                PHYSCA.14    
     :              ,TTDC(NL),QTDC(NL),TTMC(NL),QTMC(NL),TC(NL),QC(NL)       PHYSCA.15    
     :              ,CTCR(NL,NHEM),CTLR(NL,NHEM),NAVRD,NAVWT,DELT2C          PHYSCA.16    
      LOGICAL LBL,LVD,LCR,LLR,LRD,LCUBM,LCBADJ,LSL,LOC                       PHYSCA.17    
     :       ,LNOICE,LOLDBL,LCOND,LNNSK                                      PHYSCA.18    
C                                                                            PHYSCA.19    
       COMMON/CPIERS/ICFLAG(IGC,5,2),CFRAC(IGC,5),PNET(IGC,JG)               CPIERS.2     
     :               ,SNET(IGC,JG),RRFLUX(IGC,JG,6)                          CPIERS.3     
     :               ,TTSW(IGC,NL),TTLW(IGC,NL)                              CPIERS.4     
C                                                                            LEGAU.2     
C     Legendre polynomials and information about gaussian latitudes          LEGAU.3     
C                                                                            LEGAU.4     
      COMMON/LEGAU/ ALPJ(MJP),DALPJ(MJP)                                     LEGAU.5     
     +              ,ALP(NWJ2,2,JGL),DALP(NWJ2,2,JGL)                        LEGAU.6     
     +              ,RLP(NWJ2,2,JGL),RDLP(NWJ2,2,JGL)                        LEGAU.7     
     +              ,SI(JGG),CS(JGG),SISQ(JGG),CSSQ(JGG),SECSQ(JGG)          LEGAU.8     
     +              ,ALAT(JGG),GWT(JGG),AW(JGG),JH,JL,JINC                   LEGAU.9     
C                                                                            LEGAU.10    
       COMMON/GSG/GSG(IGC,JG)                                                OROG_G.2     
C                                                                            INISURF.19    
C Lookup table for vegetation to albedo: from Unified Model Doc. no. 70      INISURF.20    
C MMJ April 2000                                                             INISURF.21    
C Snow free lookup table                                                     INISURF.22    
       DIMENSION SALOOK(24)                                                  INISURF.23    
       DATA SALOOK /0.1, 0.75, 0.06, 0.14, 0.12, 0.13,                       INISURF.24    
     $ 0.13, 0.13, 0.13, 0.17, 0.16, 0.16,                                   INISURF.25    
     $ 0.19, 0.2, 0.2, 0.12, 0.17, 0.19,                                     INISURF.26    
     $ 0.19, 0.25, 0.18, 0.15, 0.12, 0.35/                                   INISURF.27    
                                                                             INISURF.28    
      DAYNEAR=0.                                                             INISURF.29    
 101  read(18,end=200) RCHECK                                                INISURF.30    
      if (abs(RCHECK+999.999).gt.0.0001) then                                INISURF.31    
          write (2,*) 'Wrong type of surface restart ',                      INISURF.32    
     :                   rcheck,abs(rcheck+999.999)                          INISURF.33    
          call abort                                                         INISURF.34    
      endif                                                                  INISURF.35    
      read(18) rrkount,rm1tape,rday,CDOY,TSTAR,TDEEP,SMSTAR,QSTAR,           INISURF.36    
     $        HSNOW,SQSTAR,SALB,SBAL,TSTARO,TDEEPO,SNET,RM2TAPE              INISURF.37    
      if (RM1TAPE.ne.RM2TAPE) then                                           INISURF.38    
        write (2,*) 'Surface (SOIL) restart record wrong.'                   INISURF.39    
        write (2,*) 'RM1TAPE != RM2TAPE',RM1TAPE,RM2TAPE                     INISURF.40    
        call abort                                                           INISURF.41    
      endif                                                                  INISURF.42    
      IF (ABS(RDAY-BEGDAY).LE.1.0E-2)THEN                                    INISURF.43    
         GOTO 1000                                                           INISURF.44    
      ELSE                                                                   INISURF.45    
         IF (ABS(RDAY-BEGDAY).LT.(ABS(DAYNEAR-BEGDAY)))THEN                  INISURF.46    
            DAYNEAR=RDAY                                                     INISURF.47    
         ENDIF                                                               INISURF.48    
         GOTO 101                                                            INISURF.49    
      ENDIF                                                                  INISURF.50    
 200  write (2,*) 'EOF on surface restart file'                              INISURF.51    
      write (2,*) 'Looking for day ',begday,' but closest was ',             INISURF.52    
     $     daynear                                                           INISURF.53    
      stop                                                                   INISURF.54    
 1000 continue                                                               INISURF.55    
C                                                                            INISURF.56    
C Read in vegetation data                                                    INISURF.57    
C                                                                            INISURF.58    
      READ(31)SVEGE                                                          INISURF.59    
C                                                                            INISURF.60    
      if (CDOY.NE.DOY) then                                                  INISURF.61    
        write (2,*) 'Surface DOY not equal to dynamical DOY.'                INISURF.62    
        write (2,*) cdoy,doy                                                 INISURF.63    
        write (2,*) 'Value from dynamics used.'                              INISURF.64    
      endif                                                                  INISURF.65    
      PRINT *, 'resetting albedo to SBAL'                                    INISURF.66    
      IF(lshort)then                                                         RESTARTFIX.1     
        DO I=1,IGC                                                           RESTARTFIX.2     
          DO IH=1,JG                                                         RESTARTFIX.3     
C Albedo field initialised from vegetation index                             INISURF.69    
C The .AND. is because the vegetation index does not contain                 INISURF.70    
C Antarctica for some unknown reason.                                        INISURF.71    
C Find latitude of Antarctica south of 60S                                   INISURF.72    
                                                                             INISURF.73    
           if(i .lt. igc/2)svlat=SI(IH)                                      INISURF.74    
           if(i .gt. igc/2)svlat=SI(JGG-IH+1)                                INISURF.75    
                                                                             INISURF.76    
           if(nint((gsg(i,ih)/(gsg(i,ih)+0.1))) .eq. 1 .and.                 INISURF.77    
     :        svlat .gt. -0.866)                                             INISURF.78    
     :        SBAL(I,IH)=SALOOK(NINT(SVEGE(I,IH)))                           INISURF.79    
C Change albedo to cool surface- this is because Tg is                       INISURF.80    
C too high (probably because of our clouds) and mucking                      INISURF.81    
C around with albedo is better than changing the solar constant              INISURF.82    
                                                                             INISURF.83    
           SBAL(I,IH) = SBAL(I,IH)+0.05                                      INISURF.84    
           SALB(I,IH) = SBAL(I,IH)                                           INISURF.85    
        end do                                                               INISURF.86    
      end do                                                                 INISURF.87    
                                                                             INISURF.88    
      print*,'Albedos set from Vegetation index'                             INISURF.89    
      print*,'Desert value set to',SALOOK(24)                                INISURF.90    
        DO j=1,jg                                                            RESTARTFIX.4     
          DO i=1,igc                                                         RESTARTFIX.5     
            TSTARO(i,j)=tstar(i,j)                                           RESTARTFIX.6     
            tdeepo(i,j)=tdeep(i,j)                                           RESTARTFIX.7     
          ENDDO                                                              RESTARTFIX.8     
        ENDDO                                                                RESTARTFIX.9     
      ELSE                                                                   RESTARTFIX.10    
        print*,'Albedos read from RESTART record'                            RESTARTFIX.11    
      ENDIF                                                                  RESTARTFIX.12    
                                                                             RESTARTFIX.13    
                                                                             RESTARTFIX.14    
                                                                             RESTARTFIX.15    
                                                                             RESTARTFIX.16    
                                                                             INISURF.97    
      END                                                                    INISURF.98    
