C**********************************************************                  ICTRAC.2     
C             SUBROUTINE ICTRAC                                              ICTRAC.3     
C**********************************************************                  ICTRAC.4     
      SUBROUTINE ICTRAC                                                      ICTRAC.5     
C                                                                            ICTRAC.6     
C     *********PMF Version 1.0 (8.4.97)*******************                   ICTRAC.7     
C     Subroutine which initialises the tracer fields.                        ICTRAC.8     
C     Tracers can be started as any function of the usual grid               ICTRAC.9     
C     point fields.                                                          ICTRAC.10    
C     Mass mixing ratios converted to volume mixing ratios for               ICTRAC.11    
C     flux form of advection.                                                ICTRAC.12    
C                                    John Methven, 10.04.95                  ICTRAC.13    
C     Slighly modified to add more tracers and                               ICTRAC.14    
C                 add array GWORK Piers Forster 22.01.97                     ICTRAC.15    
C                                                                            ICTRAC.16    
C     Changed again to combine with phys2 update                             ICTRAC.17    
C     to include surface water and temperature                               ICTRAC.18    
C     initilization.                                                         ICTRAC.19    
C     Also lets water vapour profile be cacluated by setting                 ICTRAC.20    
C     surface RH     Piers Forster  18.02.97                                 ICTRAC.21    
C                                                                            ICTRAC.22    
C      Flag LFLUX added for FLUX form of advection                           ICTRAC.23    
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    
      PARAMETER(NLTRG=NLTR*NHEM,NITRWG=7*NL*NHEM                             ICTRAC.26    
     :         ,IDDAGFL=NITRWG*MGPP,IDPLG=3*IGC)                             ICTRAC.27    
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                                                                            SPECTR.2     
C     Array ordering in SPECTR must correspond to that in GRIDP.             SPECTR.3     
C                                                                            SPECTR.4     
      COMMON/SPECTR/Z(IGB),D(IGB),T(IGB),TRA(IGB,NTRAC),SP(IGA),GS(IGA)      SPECTR.5     
     :              ,SPA(IGA),VP(IGA),DTE(IGB),TT(IGB)                       SPECTR.6     
     :              ,TRAT(IGB,NTRAC),DT(IGB),ZT(IGB)                         SPECTR.7     
     :              ,ZMI(IGB),DMI(IGB),TMI(IGB)                              SPECTR.8     
     :              ,TRAMI(IGB,NTRAC),SPMI(IGA)                              SPECTR.9     
      COMPLEX Z,D,T,TRA,SP,GS,SPA,VP,DTE,TT,TRAT,DT,ZT                       SPECTR.10    
     :       ,ZMI,DMI,TMI,TRAMI,SPMI                                         SPECTR.11    
C                                                                            SPECTR.12    
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    
C                                                                            COMFFT.2     
C     Constants and arrays needed for the fast Fourier transforms            COMFFT.3     
C                                                                            COMFFT.4     
      COMMON/COMFFT/NTGW,NRSTGW,NTWG,NRSTWG,NTGD,NRSTGD                      COMFFT.5     
     +              ,TRIG(IDA),WORK(IDF),IFAX(10)                            COMFFT.6     
C                                                                            COMFFT.7     
C                                                                            POLYNO.2     
C     Polynomial used to aid vectorization of Legendre transforms            POLYNO.3     
C                                                                            POLYNO.4     
      COMMON/POLYNO/POLY(NWJ2,2,4),CMPA(IGL)                                 POLYNO.5     
      COMPLEX CMPA                                                           POLYNO.6     
C                                                                            POLYNO.7     
C                                                                            GRIDP.2     
C     Array ordering in GRIDP must correspond to that in SPECTR.             GRIDP.3     
C     Real arrays: multi-level arrays are 1-dimensional.                     GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/ CHIG(IGD),SFG(IGD),UG(IGD),VG(IGD)                       GRIDP.6     
     *              ,ZG(IGD),DG(IGD),TG(IGD)                                 GRIDP.7     
     +              ,TRAG(IGD,NTRAC)                                         GRIDP.8     
     *              ,PLG(IGC),PJG(IGC),PMG(IGC)                              GRIDP.9     
     *              ,SPG(IGC),VPG(IGC),EG(IGD)                               GRIDP.10    
     +              ,TNLG(IGD),TRANLG(IGD,NTRAC),FUG(IGD),FVG(IGD)           GRIDP.11    
     +              ,UTG(IGD),UTRAG(IGD,NTRAC)                               GRIDP.12    
     +              ,VTG(IGD),VTRAG(IGD,NTRAC),FVGT(IGD),FUGT(IGD)           GRIDP.13    
     $              ,GRPAD(NGRPAD)                                           GRIDP.14    
C                                                                            GRIDP.15    
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/COMGRM/DUDLSG(IGC,NL),DVDLSG(IGC,NL),DTDLSG(IGC,NL)             COMGRM.2     
C                                                                            COMGRM.3     
      LOGICAL LNSURF,LRH                                                     ICTRAC.37    
      REAL RH(NL),TDUM(JG),QDUM(JG)                                          ICTRAC.38    
      COMPLEX GWORK(IGL,(3+NTRAC)*NL+2)                                      ICTRAC.39    
      REAL DAGFL(IDDAGFL),DAGPLG(IDPLG),TEMPTR(IGD),DAFTR(NLTRG*MGPP)        ICTRAC.40    
      EQUIVALENCE (DAGFL(1),CHIG(1)),(DAGPLG(1),PLG(1))                      ICTRAC.41    
     :           ,(DAFTR(1),TRAG(1,1))                                       ICTRAC.42    
      CHARACTER LHEM(2)*25                                                   ICTRAC.43    
      DATA LHEM/'  N HEM  EQUATOR.....POLE'                                  ICTRAC.44    
     :         ,'  S HEM  EQUATOR.....POLE'/                                 ICTRAC.45    
C                                                                            ICTRAC.46    
      NAMELIST/INQ/LRH,RH,LNSURF                                             ICTRAC.47    
C                                                                            ICTRAC.48    
 2010 FORMAT('0SURFACE TEMPERATURE IN DEGC',A25/20(1X,F8.2))                 ICTRAC.49    
 2020 FORMAT('0SURFACE SPECIFIC HUMIDITY IN G/KG',A25/20(1X,f8.4))           ICTRAC.50    
 2030 FORMAT(3X,20(1X,F5.1))                                                 ICTRAC.51    
C                                                                            ICTRAC.52    
      LRH=.FALSE.                                                            ICTRAC.53    
      LNSURF=.FALSE.                                                         ICTRAC.54    
      DO L=1,NL                                                              ICTRAC.55    
        RH(L)=90.0*SIGMA(L)                                                  ICTRAC.56    
      ENDDO                                                                  ICTRAC.57    
      READ(7,INQ)                                                            ICTRAC.58    
      WRITE(2,INQ)                                                           ICTRAC.59    
C                                                                            ICTRAC.60    
      IF (.NOT.LRH.AND.NTRACO.LT.NTRAC) THEN                                 ICTRAC.61    
         WRITE(2,'(A25)') 'No water Vapour. Need to set LRH to TRUE'         ICTRAC.62    
         CALL ABORT                                                          ICTRAC.63    
      ENDIF                                                                  ICTRAC.64    
C convert RH from % to fraction                                              ICTRAC.65    
      DO L=1,NL                                                              ICTRAC.66    
        RH(L)=RH(L)/100.0                                                    ICTRAC.67    
      ENDDO                                                                  ICTRAC.68    
C     Surface characteristics now read in in INISURF, not here               ICTRAC.69    
C                                                                            ICTRAC.70    
C     Save old tracers in the array TRAT and reset TRA to zero.              ICTRAC.71    
C                                                                            ICTRAC.72    
      IF (NTRACO.GT.0) THEN                                                  ICTRAC.73    
         DO 10 KK=1,NTRACO                                                   ICTRAC.74    
            DO 20 I=1,IGB                                                    ICTRAC.75    
               TRAT(I,KK)=TRA(I,KK)                                          ICTRAC.76    
               TRA(I,KK)=0.0                                                 ICTRAC.77    
 20         CONTINUE                                                         ICTRAC.78    
 10      CONTINUE                                                            ICTRAC.79    
      ENDIF                                                                  ICTRAC.80    
C                                                                            ICTRAC.81    
C     Loop over latitude                                                     ICTRAC.82    
C                                                                            ICTRAC.83    
      JL=1                                                                   ICTRAC.84    
      IF(JGL.EQ.1) REWIND 25                                                 ICTRAC.85    
      DO 400 IH=1,JG                                                         ICTRAC.86    
         JH=IH                                                               ICTRAC.87    
         IF(JGL.EQ.1) READ(25) ALP,DALP,DP,DQ                                ICTRAC.88    
C                                                                            ICTRAC.89    
C     Spectral to grid transforms for initial model variables.               ICTRAC.90    
C     Calculate the horizontal derivatives of temperature as well            ICTRAC.91    
C     as the usual derivatives done by LTI.                                  ICTRAC.92    
C                                                                            ICTRAC.93    
         CALL LTI                                                            ICTRAC.94    
         CALL LTIDT                                                          ICTRAC.95    
         NTALL=(NITRWG-1)/NCRAY                                              ICTRAC.96    
         NRSTALL=NITRWG-NCRAY*NTALL                                          ICTRAC.97    
C                                                                            ICTRAC.98    
C  Sets up surface temperature here                                          ICTRAC.99    
C                                                                            ICTRAC.100   
                                                                             ICTRAC.101   
C                                                                            ICTRAC.102   
         IF(NTALL.EQ.0) GOTO 40                                              ICTRAC.103   
         DO 30 I=1,NTALL                                                     ICTRAC.104   
 30      CALL FFT991(DAGFL(1+(I-1)*NCRAY*MGPP),WORK,TRIG,IFAX                ICTRAC.105   
     :           ,1,MGPP,MG,NCRAY,1)                                         ICTRAC.106   
 40      CALL FFT991(DAGFL(1+NTALL*NCRAY*MGPP),WORK,TRIG,IFAX                ICTRAC.107   
     :        ,1,MGPP,MG,NRSTALL,1)                                          ICTRAC.108   
         CALL FFT991(DAGPLG(1),WORK,TRIG,IFAX,1,MGPP,MG,3*NHEM,1)            ICTRAC.109   
C                                                                            ICTRAC.110   
C     Grid point calculations for surface pressure,                          ICTRAC.111   
C     temperature T (=TO+T') and vertical derivatives of U,V and T.          ICTRAC.112   
C                                                                            ICTRAC.113   
         DO 50 I=1,IGC                                                       ICTRAC.114   
            PLG(I)=EXP(PLG(I))                                               ICTRAC.115   
 50      CONTINUE                                                            ICTRAC.116   
         K=0                                                                 ICTRAC.117   
         DO 60 L=1,NL                                                        ICTRAC.118   
            DO 65 I=1,IGC                                                    ICTRAC.119   
               K=K+1                                                         ICTRAC.120   
               TG(K)=TG(K)+T0(L)                                             ICTRAC.121   
      IF (LNSURF.AND.L.EQ.NL) THEN                                           ICTRAC.122   
      TSTAR(I,IH)=TG(K)/SKAP(NL)                                             ICTRAC.123   
      ENDIF                                                                  ICTRAC.124   
 65         CONTINUE                                                         ICTRAC.125   
 60      CONTINUE                                                            ICTRAC.126   
C                                                                            ICTRAC.127   
         CALL DLSGCR(IGC,UG,RGG,DUDLSG,IGC,NL)                               ICTRAC.128   
         CALL DLSGCR(IGC,VG,RGG,DVDLSG,IGC,NL)                               ICTRAC.129   
         CALL DLSGCR(IGC,TG,RGG,DTDLSG,IGC,NL)                               ICTRAC.130   
C                                                                            ICTRAC.131   
C     Grid point calculations for new tracer fields at one                   ICTRAC.132   
C     latitude (IH).                                                         ICTRAC.133   
C                                                                            ICTRAC.134   
C initilise water vapour if LRH set  depends on RH                           ICTRAC.135   
C       goes into tracer No. 1                                               ICTRAC.136   
         IOFM=0                                                              ICTRAC.137   
         DO 810 IHEM=1,NHEM                                                  ICTRAC.138   
               SPZ=SSUM(MG,PLG(1+IOFM),1)/REAL(MG)                           ICTRAC.139   
            IF (LRH) THEN                                                    ICTRAC.140   
               DO I=1,MG                                                     ICTRAC.141   
                  J=I+IOFM                                                   ICTRAC.142   
                  ESCON=1./PLG(J)                                            ICTRAC.143   
                  K=J                                                        ICTRAC.144   
                  DO L=1,NL                                                  ICTRAC.145   
                   TRAG(K,1)=ESCON*RH(L)*PQSAT(TG(K))/SIGMA(L)               ICTRAC.146   
                   K=K+IGC                                                   ICTRAC.147   
                  ENDDO                                                      ICTRAC.148   
               ENDDO                                                         ICTRAC.149   
            ENDIF                                                            ICTRAC.150   
      IF (LNSURF) THEN                                                       ICTRAC.151   
      ESCON=1./SPZ                                                           ICTRAC.152   
      DO K=1,IGC                                                             ICTRAC.153   
      QSTAR(K,IH)=ESCON*PQSAT(TSTAR(K,IH))                                   ICTRAC.154   
CCCC      ESCON=1./SPZ                                                       ICTRAC.155   
CCCC      QSTAR(J,JH)=ESCON*PQSAT(TSTAR(J,JH))                               ICTRAC.156   
      ENDDO                                                                  ICTRAC.157   
      PRINT '(i2,x,10(F5.1,x))',ih,(ct*tstar(k,ih)-273.15,k=1,10)            ICTRAC.158   
      ENDIF                                                                  ICTRAC.159   
            IOFM=MGPP                                                        ICTRAC.160   
 810     CONTINUE                                                            ICTRAC.161   
                                                                             ICTRAC.162   
         DO 70 KK=NTRACO+1,NTRAC                                             ICTRAC.163   
            DO 300 I=1,IGD                                                   ICTRAC.164   
               TEMPTR(I)=TRAG(I,KK)                                          ICTRAC.165   
 300        CONTINUE                                                         ICTRAC.166   
            IF(KOLOUR(KK).EQ.1) THEN                                         ICTRAC.167   
               CALL PVCR(TEMPTR,1)                                           ICTRAC.168   
            ENDIF                                                            ICTRAC.169   
            IF(KOLOUR(KK).EQ.2) THEN                                         ICTRAC.170   
               CALL PVCR(TEMPTR,2)                                           ICTRAC.171   
            ENDIF                                                            ICTRAC.172   
            DO 310 I=1,IGD                                                   ICTRAC.173   
               TRAG(I,KK)=TEMPTR(I)                                          ICTRAC.174   
 310        CONTINUE                                                         ICTRAC.175   
C                                                                            ICTRAC.176   
C     Convert mass mixing ratios to volume mixing ratios.                    ICTRAC.177   
C     If LFLUX set                                                           ICTRAC.178   
            IF (LFLUX) THEN                                                  ICTRAC.179   
            DO 95 L=1,NL                                                     ICTRAC.180   
               LL=(L-1)*IGC                                                  ICTRAC.181   
               DO 94 I=1,IGC                                                 ICTRAC.182   
                  TRAG(LL+I,KK)=PLG(I)*TRAG(LL+I,KK)                         ICTRAC.183   
 94            CONTINUE                                                      ICTRAC.184   
 95         CONTINUE                                                         ICTRAC.185   
            ENDIF                                                            ICTRAC.186   
 70      CONTINUE                                                            ICTRAC.187   
C                                                                            ICTRAC.188   
C     Transform all tracer fields to spectral space at each latitude.        ICTRAC.189   
C     First do inverse FFT to give half-transforms and then call             ICTRAC.190   
C     HANAL for direct Legendre transform.                                   ICTRAC.191   
C                                                                            ICTRAC.192   
         NTTR=(NLTRG-1)/NCRAY                                                ICTRAC.193   
         NRSTTR=NLTRG-NCRAY*NTTR                                             ICTRAC.194   
         IF(NTTR.EQ.0) GO TO 110                                             ICTRAC.195   
         DO 100 I=1,NTTR                                                     ICTRAC.196   
 100        CALL FFT991(DAFTR(1+(I-1)*NCRAY*MGPP),WORK,TRIG,IFAX             ICTRAC.197   
     :           ,1,MGPP,MG,NCRAY,-1)                                        ICTRAC.198   
 110     CALL FFT991(DAFTR(1+ NTTR*NCRAY*MGPP),WORK,TRIG,IFAX                ICTRAC.199   
     :        ,1,MGPP,MG,NRSTTR,-1)                                          ICTRAC.200   
         CALL HANAL(TRAG,GWORK,TRA,NLTR,2)                                   ICTRAC.201   
C                                                                            ICTRAC.202   
C     End of latitude loop. Note that if JGL=JG then JINC=1                  ICTRAC.203   
C          if JGL=1  then JINC=0                                             ICTRAC.204   
C     Therefore JL=JH(=IH) if JGL=JG, or JL=1 if JGL=1.                      ICTRAC.205   
C                                                                            ICTRAC.206   
         JL=JL+JINC                                                          ICTRAC.207   
 400  CONTINUE                                                               ICTRAC.208   
C                                                                            ICTRAC.209   
C     Return old tracers from the restart record into array TRA and          ICTRAC.210   
C     set the t-1 record for the new tracers.                                ICTRAC.211   
C                                                                            ICTRAC.212   
      IF (NTRACO.GT.0) THEN                                                  ICTRAC.213   
         DO 410 KK=1,NTRACO                                                  ICTRAC.214   
            DO 420 I=1,IGB                                                   ICTRAC.215   
               TRA(I,KK)=TRAT(I,KK)                                          ICTRAC.216   
               TRAT(I,KK)=0.0                                                ICTRAC.217   
 420        CONTINUE                                                         ICTRAC.218   
 410     CONTINUE                                                            ICTRAC.219   
      ENDIF                                                                  ICTRAC.220   
      DO 430 KK=NTRACO+1,NTRAC                                               ICTRAC.221   
         DO 440 I=1,IGB                                                      ICTRAC.222   
            TRAMI(I,KK)=TRA(I,KK)                                            ICTRAC.223   
 440     CONTINUE                                                            ICTRAC.224   
 430  CONTINUE                                                               ICTRAC.225   
C                                                                            ICTRAC.226   
C    writes out surface temp and humdidity to channel 14                     ICTRAC.227   
C     Continue to write out restart in old format....                        ICTRAC.228   
      if (LNSURF) WRITE(14,*) ((tstar(i,j),j=1,jg),i=1,igc),                 ICTRAC.229   
     $     ((qstar(i,j),j=1,jg),i=1,igc)                                     ICTRAC.230   
      WRITE(2,'(A40)') 'O DEG LONG X-SECTS SHOWN BELOW'                      ICTRAC.231   
                                                                             ICTRAC.232   
      DO 820 IHEM=1,NHEM                                                     ICTRAC.233   
      DO 510 J=1,JG                                                          ICTRAC.234   
      TDUM(J)=CT*TSTAR(IHEM,J)-273.15                                        ICTRAC.235   
 510  QDUM(J)=CQ*QSTAR(IHEM,J)                                               ICTRAC.236   
      IF(JG.LE.20) THEN                                                      ICTRAC.237   
        DO 520 NCHAN=2,2                                                     ICTRAC.238   
        WRITE(NCHAN,2010) LHEM(IHEM),(TDUM(J),J=JG,1,-1)                     ICTRAC.239   
  520   WRITE(NCHAN,2020) LHEM(IHEM),(QDUM(J),J=JG,1,-1)                     ICTRAC.240   
      ELSE                                                                   ICTRAC.241   
        DO 530 NCHAN=2,2                                                     ICTRAC.242   
        WRITE(NCHAN,2010) LHEM(IHEM),(TDUM(J),J=JG,2,-2)                     ICTRAC.243   
        WRITE(NCHAN,2030)            (TDUM(J),J=JG-1,1,-2)                   ICTRAC.244   
        WRITE(NCHAN,2020) LHEM(IHEM),(QDUM(J),J=JG,2,-2)                     ICTRAC.245   
  530   WRITE(NCHAN,2030)            (QDUM(J),J=JG-1,1,-2)                   ICTRAC.246   
      ENDIF                                                                  ICTRAC.247   
  820 CONTINUE                                                               ICTRAC.248   
      RETURN                                                                 ICTRAC.249   
      END                                                                    ICTRAC.250   
