C**********************************************************                  SFCT.2     
C             SUBROUTINE SFCT                                                SFCT.3     
C**********************************************************                  SFCT.4     
C   Subroutine to find new T and Q based on DOY and climatology              SFCT.5     
      SUBROUTINE SFCT(PLG,JH,IFIRST,TROPHT)                                  SFCT.6     
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                                                                            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    
      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/GSG/GSG(IGC,JG)                                                OROG_G.2     
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    
      INTEGER JH,IFIRST                                                      SFCT.13    
      REAL TSTAR1(IGC,JG),TSTAR2(IGC,JG),PLG(IGC)                            SFCT.14    
      integer cmth                                                           SFCT.15    
      character*3 mn(13)                                                     SFCT.16    
      character*31 sstfile                                                   SFCT.17    
      integer mnlen(13)                                                      SFCT.18    
      data mn/'dec','jan','feb','mar','apr','may','jun','jul','aug'          SFCT.19    
     &        ,'sep','oct','nov','dec'/                                      SFCT.20    
      data mth1/0/                                                           SFCT.21    
      real shdum                                                             SFCT.22    
      real tropht(mg,nhem,jg)                                                SFCT.23    
      save mth1                                                              SFCT.24    
c                                                                            SFCT.25    
C                                                                            SFCT.26    
      RHSCL=288.0*GASCON/GA                                                  SFCT.27    
      CALL CALNDR(DOY,MTH2,AMFRAC)                                           SFCT.28    
      IF (IFIRST.EQ.1) THEN                                                  SFCT.29    
C                                                                            SFCT.30    
       IF (JH.EQ.1) THEN                                                     SFCT.31    
        cmth=mth2+1                                                          SFCT.32    
        IF (cmth.eq.13) cmth=1                                               SFCT.33    
        write(sstfile,'(a,i3.3,a,i3.3,a)')                                   SFCT.34    
     &      'tqpap_'//mn(cmth)//'_jg',jg,'_mg',mg,'_nhem2.dat'               SFCT.35    
        open(unit=45,file='climdata/'//sstfile,status='old')                 SFCT.36    
c                                                                            SFCT.37    
       ENDIF                                                                 SFCT.38    
C read into tstar2 because changes below to tstar1                           SFCT.39    
       DO i2=1,mg                        ! NH                                SFCT.40    
         read(45,*)sst,ssq,ssp,shdum,tropht(i2,1,jh)                         SFCT.41    
         tstar2(i2,jh)=sst/ct                                                SFCT.42    
       ENDDO                                                                 SFCT.43    
c                                                                            SFCT.44    
       DO i2=1,mg                        ! SH                                SFCT.45    
          IF (nhem.eq.2) then                                                SFCT.46    
            read(45,*)sst,ssq,ssp,shdum,tropht(i2,2,jh)                      SFCT.47    
            tstar2(i2+mgpp,jh)=sst/ct                                        SFCT.48    
          ELSE                                                               SFCT.49    
            read(45,*)         ! because climatology is global               SFCT.50    
          ENDIF                                                              SFCT.51    
       ENDDO                                                                 SFCT.52    
c                                                                            SFCT.53    
       IF (JH.EQ.JG) THEN                                                    SFCT.54    
         CLOSE(45)                                                           SFCT.55    
         write(2,*)'CLIMATOLOGICAL TROPOPAUSE HEIGHT'                        SFCT.56    
         do k=1,nhem                                                         SFCT.57    
           write(2,*)(tropht(1,k,j),j=1,jg)                                  SFCT.58    
         enddo                                                               SFCT.59    
       ENDIF                                                                 SFCT.60    
                                                                             SFCT.61    
       MTH1=CMTH                                                             SFCT.62    
      ENDIF  ! IFIRST                                                        SFCT.63    
c                                                                            SFCT.64    
      IF (MTH2.NE.MTH1) THEN   !time to change month                         SFCT.65    
                                                                             SFCT.66    
       IF (JH.EQ.1) THEN                                                     SFCT.67    
        cmth=mth2+1                                                          SFCT.68    
        if (cmth.eq.13) cmth=1                                               SFCT.69    
        write(sstfile,'(a,i3.3,a,i3.3,a)')                                   SFCT.70    
     &      'tqpap_'//mn(cmth+1)//'_jg',jg,'_mg',mg,'_nhem2.dat'             SFCT.71    
        open(unit=46,file='climdata/'//sstfile,status='old')                 SFCT.72    
       ENDIF                                                                 SFCT.73    
                                                                             SFCT.74    
c transfer tstar2 to tstar1 for latitude                                     SFCT.75    
       DO i2=1,igc                                                           SFCT.76    
         tstar1(i2,jh)=tstar2(i2,jh)                                         SFCT.77    
       ENDDO                                                                 SFCT.78    
c read in new tstar2                                                         SFCT.79    
       DO i2=1,mg                        ! NH                                SFCT.80    
         read(46,*)sst,ssq,ssp,shdum,tropht(i2,1,jh)                         SFCT.81    
         tstar2(i2,jh)=sst/ct                                                SFCT.82    
       ENDDO                                                                 SFCT.83    
c                                                                            SFCT.84    
       DO i2=1,mg                        ! SH                                SFCT.85    
         IF (nhem.eq.2) then                                                 SFCT.86    
           read(46,*)sst,ssq,ssp,shdum,tropht(i2,2,jh)                       SFCT.87    
           tstar2(i2+mgpp,jh)=sst/ct                                         SFCT.88    
         ELSE                                                                SFCT.89    
           read(46,*)  ! because climatology is global                       SFCT.90    
         ENDIF                                                               SFCT.91    
       ENDDO                                                                 SFCT.92    
       IF (JH.EQ.JG) THEN                                                    SFCT.93    
         CLOSE(46)                                                           SFCT.94    
         MTH1=MTH2  ! stop doing loop until next month                       SFCT.95    
       ENDIF                                                                 SFCT.96    
      ENDIF   ! MTH2.NE.MTH1                                                 SFCT.97    
c                                                                            SFCT.98    
c                                                                            SFCT.99    
c  set TSTAR and QSTAR                                                       SFCT.100   
C                                                                            SFCT.101   
C                                                                            SFCT.102   
      IF (.NOT.LSL) then                                                     SFCT.103   
        DO ihem=1,nhem                                                       SFCT.104   
          iofm=(ihem-1)*mgpp                                                 SFCT.105   
          DO i2=1,mg                                                         SFCT.106   
            j=i2+iofm                                                        SFCT.107   
            IF (gsg(j,jh).gt.0.) then                                        SFCT.108   
              tstar(j,jh)=tstar2(j,jh)*amfrac+                               SFCT.109   
     $                 tstar1(j,jh)*(1.0-amfrac)                             SFCT.110   
              IF (LPERPET) THEN                                              SFCT.111   
                escon=1./exp(-gsg(j,jh)/RHSCL)                               SFCT.112   
              ELSE                                                           SFCT.113   
                escon=1./plg(j)                                              SFCT.114   
              ENDIF                                                          SFCT.115   
              sqstar(j,jh)=escon*pqsat(tstar(j,jh))                          SFCT.116   
              qstar(j,jh)=sqstar(j,jh)*0.75                                  SFCT.117   
            endif                                                            SFCT.118   
          enddo                                                              SFCT.119   
        enddo                                                                SFCT.120   
      endif                                                                  SFCT.121   
      IF (.NOT.LOC) THEN                                                     SFCT.122   
        DO ihem=1,nhem                                                       SFCT.123   
          iofm=(ihem-1)*mgpp                                                 SFCT.124   
          DO i2=1,mg                                                         SFCT.125   
            j=i2+iofm                                                        SFCT.126   
            IF (gsg(j,jh).le.0.) then                                        SFCT.127   
              tstar(j,jh)=tstar2(j,jh)*amfrac+                               SFCT.128   
     $              tstar1(j,jh)*(1.0-amfrac)                                SFCT.129   
              IF (LPERPET) THEN                                              SFCT.130   
                escon=1.                                                     SFCT.131   
              ELSE                                                           SFCT.132   
                escon=1./plg(j)                                              SFCT.133   
              ENDIF                                                          SFCT.134   
              sqstar(j,jh)=escon*pqsat(tstar(j,jh))                          SFCT.135   
              qstar(j,jh)=sqstar(j,jh)                                       SFCT.136   
            endif                                                            SFCT.137   
          enddo                                                              SFCT.138   
        enddo                                                                SFCT.139   
      ENDIF                                                                  SFCT.140   
      RETURN                                                                 SFCT.141   
      END                                                                    SFCT.142   
