      PROGRAM OFFLINE                                                        OFFLINE.2     
C                                                                            OFFLINE.3     
C     Offline trajectory code for use with winds from ECMWF                  OFFLINE.4     
C     GRIB files, Reading spectral model (BGCM5, RSGUP3 or RSGCM)            OFFLINE.5     
C     history files, or UKMO Unified Model output.                           OFFLINE.6     
C                                                                            JOBID.1     
C     VERSION 3 customised for ECMWF data, including updates.                JOBID.2     
C                                                                            JOBID.3     
C                                                                            OFFLINE.7     
C     Author: John Methven, University of Reading  (20/3/97).                OFFLINE.8     
C                                                                            OFFLINE.9     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)                                       COMPSG.2     
C      PARAMETER(IGDLAP=1,IGCP=IGC)                                          COMPSG.3     
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)             COMPSG.4     
     :,BLETAM(IGCP,JG)                                                       SFCDATA.14    
C                                                                            COMPSG.5     
C                                                                            PATH.2     
C     Must ensure that NSTSAV >= NSTEPS.                                     PATH.3     
C                                                                            PATH.4     
      PARAMETER(NSTSAV=120)                                                  JOBID.13    
      COMMON/PATH/YP(NSTSAV,3)                                               PATH.6     
C                                                                            PATH.7     
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      REAL YSTART(3)                                                         OFFLINE.18    
      INTEGER ITYPE,IEND,NGAP,ISET,IPOS,NTIME,KTIME,ITP,ITEL,ITELP           OFFLINE.19    
C                                                                            OFFLINE.20    
      CALL INITAL                                                            OFFLINE.21    
C                                                                            OFFLINE.22    
C     Read first history file record for the initial g.p. fields.            OFFLINE.23    
C                                                                            OFFLINE.24    
      IF (LSPECTRAL) THEN                                                    OFFLINE.25    
         CALL READREC                                                        OFFLINE.26    
      ELSE                                                                   OFFLINE.27    
         IF (LOROG) CALL READOROG                                            OFFLINE.28    
         CALL READGP                                                         OFFLINE.29    
      ENDIF                                                                  OFFLINE.30    
      IF (LSFCATTR) THEN                                                     SFCDATA.16    
         PFAC=1.                                                             SFCDATA.17    
         IF ((KHH.EQ.12).OR.(KHH.EQ.0)) THEN                                 SFCDATA.18    
            PFAC=0.5                                                         SFCDATA.19    
         ENDIF                                                               SFCDATA.20    
C                                                                            SFCDATA.21    
C     First precip record is for accumulation over 12 hour forecast.         SFCDATA.22    
C                                                                            SFCDATA.23    
         DO 14 J=1,JG                                                        SFCDATA.24    
            DO 16 I=1,IGC                                                    SFCDATA.25    
               PRECIP6HR(I,J)=PRECIP(I,J)*PFAC                               SFCDATA.26    
               PRECST6HR(I,J)=PRECST(I,J)*PFAC                               SFCDATA.27    
               EVAP6HR(I,J)=EVAP(I,J)*PFAC                                   SFCDATA.28    
               PCRAD6HR(I,J)=PCRAD(I,J)*PFAC/(THIST*86400.)                  SFCDATA.29    
 16         CONTINUE                                                         SFCDATA.30    
 14      CONTINUE                                                            SFCDATA.31    
      ENDIF                                                                  SFCDATA.32    
C                                                                            OFFLINE.31    
C     Initialise particle positions.                                         OFFLINE.32    
C     Calculate initial attributes and pressure at particles' positions,     OFFLINE.33    
C     if required.                                                           OFFLINE.34    
C                                                                            OFFLINE.35    
      KTIME=1                                                                OFFLINE.36    
      CALL INIPOSN(0,1)                                                      OFFLINE.37    
      IF ((NATTR.GT.0).OR.(LPOUT)) CALL SETATTR(0,1)                         OFFLINE.38    
      DAY=DAY+THIST                                                          OFFLINE.39    
      NGAP=NINT(TRELEASE/THIST)                                              OFFLINE.40    
      IEND=NINT(TINTEG/THIST)                                                OFFLINE.41    
C                                                                            OFFLINE.42    
C     Loop over intervals between model (history file) outputs.              OFFLINE.43    
C                                                                            OFFLINE.44    
      DO 990 NTIME=1,IEND                                                    OFFLINE.45    
C                                                                            OFFLINE.46    
C     Put winds and surface pressure from time 'tplus' into arrays           OFFLINE.47    
C     for time 'tminus'.                                                     OFFLINE.48    
C                                                                            OFFLINE.49    
         DO 20 I=1,IGDLA                                                     OFFLINE.50    
            UM(I)=URHS(I)                                                    OFFLINE.51    
            VM(I)=VRHS(I)                                                    OFFLINE.52    
            SDM(I)=SDRHS(I)                                                  OFFLINE.53    
 20      CONTINUE                                                            OFFLINE.54    
         DO 30 J=1,JG                                                        OFFLINE.55    
            DO 32 I=1,IGC                                                    OFFLINE.56    
               PLGLAM(I,J)=PLGLA(I,J)                                        OFFLINE.57    
 32         CONTINUE                                                         OFFLINE.58    
 30      CONTINUE                                                            OFFLINE.59    
         IF (LOROG.OR.(ILEVTYPE.EQ.2)) THEN                                  OFFLINE.60    
            DO 40 I=1,IGDLA                                                  OFFLINE.61    
               PSGLAM(I)=PSGLA(I)                                            OFFLINE.62    
 40         CONTINUE                                                         OFFLINE.63    
         ENDIF                                                               OFFLINE.64    
         IF (LSFCATTR) THEN                                                  SFCDATA.33    
            DO 34 J=1,JG                                                     SFCDATA.34    
               DO 36 I=1,IGC                                                 SFCDATA.35    
                  BLETAM(I,J)=BLETA(I,J)                                     SFCDATA.36    
                  PRECIPM(I,J)=PRECIP(I,J)                                   SFCDATA.37    
                  PRECSTM(I,J)=PRECST(I,J)                                   SFCDATA.38    
                  EVAPM(I,J)=EVAP(I,J)                                       SFCDATA.39    
                  BLHEIGHTM(I,J)=BLHEIGHT(I,J)                               SFCDATA.40    
                  PCRADM(I,J)=PCRAD(I,J)                                     SFCDATA.41    
                  TEMP2MM(I,J)=TEMP2M(I,J)                                   SFCDATA.42    
                  TDEW2MM(I,J)=TDEW2M(I,J)                                   SFCDATA.43    
                  ALLCM(I,J)=ALLC(I,J)                                       SFCDATA.44    
                  AMLCM(I,J)=AMLC(I,J)                                       SFCDATA.45    
                  AHLCM(I,J)=AHLC(I,J)                                       SFCDATA.46    
 36            CONTINUE                                                      SFCDATA.47    
 34         CONTINUE                                                         SFCDATA.48    
         ENDIF                                                               SFCDATA.49    
C                                                                            OFFLINE.65    
C     Copy attributes from time 'tplus' to scratch files for 'tminus'.       OFFLINE.66    
C                                                                            OFFLINE.67    
         IF (LEVERY) THEN                                                    OFFLINE.68    
            DO 50 IATTR=1,NATTR                                              OFFLINE.69    
               ITYPE=IATTRTYP(IATTR)                                         OFFLINE.70    
               IF (ITYPE.LT.7) THEN                                          PSIATTR.1     
                  ICHAN1=NCGP(ITYPE)                                         OFFLINE.72    
                  ICHAN2=ICHAN1+MAXATTR                                      OFFLINE.73    
                  CALL COPYATTR(ICHAN1,ICHAN2)                               OFFLINE.74    
               ENDIF                                                         OFFLINE.75    
 50         CONTINUE                                                         OFFLINE.76    
         ENDIF                                                               OFFLINE.77    
C                                                                            OFFLINE.78    
C     Obtain winds from next part of history record for time 'tplus'.        OFFLINE.79    
C                                                                            OFFLINE.80    
         IF (LSPECTRAL) THEN                                                 OFFLINE.81    
            CALL READREC                                                     OFFLINE.82    
         ELSE                                                                OFFLINE.83    
            CALL READGP                                                      OFFLINE.84    
         ENDIF                                                               OFFLINE.85    
         IDATE=KYY*1000000+KMM*10000+KDD*100+KHH                             SFCDATA.50    
         IF (LSFCATTR) THEN                                                  SFCDATA.51    
            IF (LFORW) THEN                                                  SFCDATA.52    
               IF (LFORC.OR.((KHH.EQ.12).OR.(KHH.EQ.0))) THEN                SFCDATA.53    
                  DO 42 J=1,JG                                               SFCDATA.54    
                     DO 44 I=1,IGC                                           SFCDATA.55    
                        PRECIP6HR(I,J)=PRECIP(I,J)-PRECIPM(I,J)              SFCDATA.56    
                        PRECST6HR(I,J)=PRECST(I,J)-PRECSTM(I,J)              SFCDATA.57    
                        EVAP6HR(I,J)=EVAP(I,J)-EVAPM(I,J)                    SFCDATA.58    
                        PCRAD6HR(I,J)=(PCRAD(I,J)-PCRADM(I,J))               SFCDATA.59    
     :                             /(THIST*86400.)                           SFCDATA.60    
 44                  CONTINUE                                                SFCDATA.61    
 42               CONTINUE                                                   SFCDATA.62    
               ELSE                                                          SFCDATA.63    
                  DO 46 J=1,JG                                               SFCDATA.64    
                     DO 48 I=1,IGC                                           SFCDATA.65    
                        PRECIP6HR(I,J)=PRECIP(I,J)                           SFCDATA.66    
                        PRECST6HR(I,J)=PRECST(I,J)                           SFCDATA.67    
                        EVAP6HR(I,J)=EVAP(I,J)                               SFCDATA.68    
                        PCRAD6HR(I,J)=PCRAD(I,J)/(THIST*86400.)              SFCDATA.69    
 48                  CONTINUE                                                SFCDATA.70    
 46               CONTINUE                                                   SFCDATA.71    
               ENDIF                                                         SFCDATA.72    
            ELSE                                                             SFCDATA.73    
               IF (LFORC.OR.((KHH.EQ.6).OR.(KHH.EQ.18))) THEN                SFCDATA.74    
                  DO 52 J=1,JG                                               SFCDATA.75    
                     DO 54 I=1,IGC                                           SFCDATA.76    
                        PRECIP6HR(I,J)=PRECIPM(I,J)-PRECIP(I,J)              SFCDATA.77    
                        PRECST6HR(I,J)=PRECSTM(I,J)-PRECST(I,J)              SFCDATA.78    
                        EVAP6HR(I,J)=EVAPM(I,J)-EVAP(I,J)                    SFCDATA.79    
                        PCRAD6HR(I,J)=(PCRADM(I,J)-PCRAD(I,J))               SFCDATA.80    
     :                             /(THIST*86400.)                           SFCDATA.81    
 54                  CONTINUE                                                SFCDATA.82    
 52               CONTINUE                                                   SFCDATA.83    
               ELSE                                                          SFCDATA.84    
                  DO 56 J=1,JG                                               SFCDATA.85    
                     DO 58 I=1,IGC                                           SFCDATA.86    
                        PRECIP6HR(I,J)=PRECIPM(I,J)                          SFCDATA.87    
                        PRECST6HR(I,J)=PRECSTM(I,J)                          SFCDATA.88    
                        EVAP6HR(I,J)=EVAPM(I,J)                              SFCDATA.89    
                        PCRAD6HR(I,J)=PCRADM(I,J)/(THIST*86400.)             SFCDATA.90    
 58                  CONTINUE                                                SFCDATA.91    
 56               CONTINUE                                                   SFCDATA.92    
               ENDIF                                                         SFCDATA.93    
            ENDIF                                                            SFCDATA.94    
         ENDIF                                                               SFCDATA.95    
C                                                                            SFCDATA.96    
C     Change forecast flag after calculating 6 hour accumulation             SFCDATA.97    
C     so that the T+006 forecast is not changed incorrectly for              SFCDATA.98    
C     forward trajs and first forecast window is not treated as              SFCDATA.99    
C     an analysis window for back trajs.                                     SFCDATA.100   
C                                                                            SFCDATA.101   
         IF (IDATE.GT.IDATADATE) THEN                                        SFCDATA.102   
            LFORC=.TRUE.                                                     SFCDATA.103   
         ELSE                                                                SFCDATA.104   
            LFORC=.FALSE.                                                    SFCDATA.105   
         ENDIF                                                               SFCDATA.106   
C                                                                            OFFLINE.86    
C     Loop over release sets.                                                OFFLINE.87    
C                                                                            OFFLINE.88    
         DO 980 ISET=1,NSETS                                                 OFFLINE.89    
            IPOS=(ISET-1)*NPSET                                              OFFLINE.90    
            ITP=KTIME+1-(ISET-1)*NINT(TRELEASE/THIST)                        OFFLINE.91    
            IF (ITP.LE.1) ITP=ITP+NHISTS-1                                   OFFLINE.92    
            ITELP=(ITP-1)*NJUMP+1                                            OFFLINE.93    
            ITEL=ITELP-NJUMP                                                 OFFLINE.94    
C                                                                            OFFLINE.95    
C     Loop over particles within set.                                        OFFLINE.96    
C                                                                            OFFLINE.97    
            DO 982 II=1,NPSET                                                OFFLINE.98    
               ILAB=II+IPOS                                                  OFFLINE.99    
               IF (POSN(ITEL,ILAB,3).GT.0.0) THEN                            OFFLINE.100   
C                                                                            OFFLINE.101   
C     Operate Runge-Kutta scheme on one particle from time 'tminus' to       OFFLINE.102   
C     time 'tplus' if the particle is switched on.                           OFFLINE.103   
C                                                                            OFFLINE.104   
                  DO 100 I=1,3                                               OFFLINE.105   
                     YSTART(I)=POSN(ITEL,ILAB,I)                             OFFLINE.106   
 100              CONTINUE                                                   OFFLINE.107   
                  CALL RKDUMB(YSTART,4,DAY-THIST,DAY,NSTEPS,H1)              OFFLINE.108   
C                                                                            OFFLINE.109   
C     Ensure that particles' longitude coordinates are cyclic.               OFFLINE.110   
C     Store trajectory coordinates.                                          OFFLINE.111   
C                                                                            OFFLINE.112   
                  IF (.NOT.LEVERY) THEN                                      OFFLINE.113   
                     DO 108 I=1,3                                            OFFLINE.114   
                        YP(1,I)=YSTART(I)                                    OFFLINE.115   
 108                 CONTINUE                                                OFFLINE.116   
                  ENDIF                                                      OFFLINE.117   
                  DO 110 IINTER=1,NJUMP                                      OFFLINE.118   
                     IF (YP(IINTER,1).LT.0.) THEN                            OFFLINE.119   
                        YMOD=-YP(IINTER,1)                                   OFFLINE.120   
                        NCYCLE=INT(YMOD/PI2)                                 OFFLINE.121   
                        YP(IINTER,1)=-(YMOD-NCYCLE*PI2)+PI2                  OFFLINE.122   
                     ELSE                                                    OFFLINE.123   
                        NCYCLE=INT(YP(IINTER,1)/PI2)                         OFFLINE.124   
                        YP(IINTER,1)=YP(IINTER,1)-NCYCLE*PI2                 OFFLINE.125   
                     ENDIF                                                   OFFLINE.126   
                     DO 120 I=1,3                                            OFFLINE.127   
                        POSN(ITEL+IINTER,ILAB,I)=YP(IINTER,I)                OFFLINE.128   
 120                 CONTINUE                                                OFFLINE.129   
 110              CONTINUE                                                   OFFLINE.130   
               ENDIF                                                         OFFLINE.131   
 982        CONTINUE                                                         OFFLINE.132   
C                                                                            OFFLINE.133   
C     Find attributes along trajectories if required.                        OFFLINE.134   
C                                                                            OFFLINE.135   
            IF ((NATTR.GT.0).OR.(LPOUT)) CALL SETATTR(IPOS,ITELP)            OFFLINE.136   
C                                                                            OFFLINE.137   
C     Write out "mature" trajectories to ECMWF format file.                  OFFLINE.138   
C                                                                            OFFLINE.139   
            IF (ITP.EQ.NHISTS) THEN                                          OFFLINE.140   
               IF ((DAY-BEGDAY).GE.RECINT) THEN                              OFFLINE.141   
                  CALL WROUT(IPOS,NPSET)                                     OFFLINE.142   
               ENDIF                                                         OFFLINE.143   
C                                                                            OFFLINE.144   
C     Initialise next set of trajectories if time to complete them.          OFFLINE.145   
C                                                                            OFFLINE.146   
               IF (NTIME.LE.(IEND-NHISTS+1)) THEN                            OFFLINE.147   
                  CALL INIPOSN(IPOS,1)                                       OFFLINE.148   
                  IF ((NATTR.GT.0).OR.(LPOUT)) CALL SETATTR(IPOS,1)          OFFLINE.149   
               ELSE                                                          OFFLINE.150   
C                                                                            OFFLINE.151   
C     Switch off particles in set if insufficient time to finish.            OFFLINE.152   
C                                                                            OFFLINE.153   
                  IF (NTIME.LT.IEND) THEN                                    OFFLINE.154   
                     DO 200 I=1,IPTS                                         OFFLINE.155   
                        DO 210 II=1,NPSET                                    OFFLINE.156   
                           POSN(I,IPOS+II,3)=0.                              OFFLINE.157   
 210                    CONTINUE                                             OFFLINE.158   
 200                 CONTINUE                                                OFFLINE.159   
                  ENDIF                                                      OFFLINE.160   
               ENDIF                                                         OFFLINE.161   
            ENDIF                                                            OFFLINE.162   
 980     CONTINUE                                                            OFFLINE.163   
C                                                                            OFFLINE.164   
C     End of loop over history file intervals.                               OFFLINE.165   
C                                                                            OFFLINE.166   
         KTIME=KTIME+1                                                       OFFLINE.167   
         IF (KTIME.EQ.NHISTS) KTIME=1                                        OFFLINE.168   
         DAY=DAY+THIST                                                       OFFLINE.169   
 990  CONTINUE                                                               OFFLINE.170   
C                                                                            OFFLINE.171   
C     Write all trajectory data to a ".bin" file.                            OFFLINE.172   
C                                                                            OFFLINE.173   
C     Removed call to binary output WRBIN.                                   TRAJFORM.1     
C                                                                            OFFLINE.175   
      STOP                                                                   OFFLINE.176   
      END                                                                    OFFLINE.177   
C     ******************************************************************     OFFLINE.178   
      SUBROUTINE WROUT(IPOS,NPLEN)                                           WROUT.2     
C                                                                            WROUT.3     
C     Writes trajectory data for "mature" set to a file.                     WROUT.4     
C     Can output pressure as the vertical coordinate.                        WROUT.5     
C                                                                            WROUT.6     
C     IPOS = marker for start of "mature" set.                               WROUT.7     
C     NPLEN = number of particles to output.                                 WROUT.8     
C                                                                            WROUT.9     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/CLUSTERS/NCLUSTERS,IPOSN(MAXCLUS)                               CLUSTERS.2     
     :,IPOINTER(MAXCLUS)                                                     BUGS3EC.3     
     :,XCLUSTER(MAXCLUS),YCLUSTER(MAXCLUS),ZCLUSTER(MAXCLUS)                 CLUSTERS.3     
     :,XSPACE(MAXCLUS),YSPACE(MAXCLUS),ZSPACE(MAXCLUS)                       CLUSTERS.4     
     :,NXACR(MAXCLUS),NYACR(MAXCLUS),PHILIM,INISURF                          CLUSTERS.5     
C                                                                            CLUSTERS.6     
      REAL POINTS(NFPPAR),AH                                                 WROUT.16    
      INTEGER ISTEP,NCDATE,IPOS,NPLEN,ILAB,ITIME                             WROUT.17    
      INTEGER NDIGDAT                                                        Y2K.7     
      LOGICAL LYRNAMSAV                                                      Y2K.8     
C                                                                            Y2K.9     
      LYRNAMSAV=LYRNAM                                                       Y2K.10    
      LYRNAM=.FALSE.                                                         Y2K.11    
C                                                                            WROUT.18    
 1000 FORMAT(I5,X,F8.2,(10E13.5))                                            TRAJFORM.4     
C                                                                            WROUT.20    
C     Change the units of the coordinates to conform with the                WROUT.21    
C     standard. (T:days, long,lat:degrees, levels:1000.*ALEV)                WROUT.22    
C                                                                            WROUT.23    
C     LPOUT switches from output in eta coordinate to output                 WROUT.24    
C     in pressure coordinate.                                                WROUT.25    
C                                                                            WROUT.26    
      DAY=DAY-RECINT                                                         WROUT.27    
      IF (IUVFORMAT.EQ.2) THEN                                               WROUT.28    
         CALL MAKEUM(FSTEMO,IOFFOUT,INPFNAME,NCDATE)                         WROUT.29    
      ELSE                                                                   WROUT.30    
         CALL MAKENAME(FSTEMO,IOFFOUT,INPFNAME,NCDATE,LGPQ)                  WROUT.31    
      ENDIF                                                                  WROUT.32    
      DAY=DAY+RECINT                                                         WROUT.33    
      NDIGDAT=7                                                              Y2K.12    
      IF (NCDATE.GT.99999999) NDIGDAT=9                                      Y2K.13    
      LYRNAM=LYRNAMSAV                                                       Y2K.14    
      OPEN(NCEC,FILE=INPFNAME(1:IOFFOUT+NDIGDAT),FORM='FORMATTED')           Y2K.15    
C                                                                            WROUT.35    
      IF (NCDATE.GT.IDATADATE) THEN                                          WROUT.36    
         LFORECAST=.TRUE.                                                    WROUT.37    
      ELSE                                                                   WROUT.38    
         LFORECAST=.FALSE.                                                   WROUT.39    
      ENDIF                                                                  WROUT.40    
      WRITE(NCEC,'(A25,I10)') ' TRAJECTORY BASE TIME IS ',NCDATE             Y2K.16    
      WRITE(NCEC,'(A19,I10)') ' DATA BASE TIME IS ',IDATADATE                Y2K.17    
      NHOURS=NINT(24.*THIST)                                                 WROUT.43    
      WRITE(NCEC,'(A18,I4,A20,I4,A10)') ' DATA INTERVAL IS '                 WROUT.44    
     :     ,NHOURS,' HOURS AND CONTAINS ',NSTEPS,' TIMESTEPS'                WROUT.45    
      WRITE(NCEC,'(A33,I8)')                                                 NEWHEAD.1     
     :     ' TOTAL NUMBER OF TRAJECTORIES IS ',NPLEN                         WROUT.47    
      WRITE(NCEC,'(A25,I4)')                                                 WROUT.48    
     :     ' NUMBER OF ATTRIBUTES IS ',NATTR                                 WROUT.49    
      WRITE(NCEC,'(A)') ' ATTRIBUTE TYPES = '                                NEWHEAD.2     
      WRITE(NCEC,'(20I4)') IATTRTYP(1:NATTR)                                 NEWHEAD.3     
      WRITE(NCEC,'(A,I4)') ' NUMBER OF CLUSTERS IS ',NCLUSTERS               NEWHEAD.4     
      WRITE(NCEC,'(A)') ' CLUSTER POINTERS = '                               NEWHEAD.5     
      WRITE(NCEC,'(10I7)') IPOINTER(1:NCLUSTERS)                             NEWHEAD.6     
      WRITE(NCEC,'(A)') ' 3D TRAJECTORY ? (T OR F): T'                       WROUT.50    
      WRITE(NCEC,'(A,L1)') ' FORECAST DATA ? (T OR F): ',LFORECAST           WROUT.51    
      WRITE(NCEC,'(A,L1)') ' FORWARD TRAJECTORY ? (T OR F): ',LFORW          WROUT.52    
C                                                                            WROUT.53    
      DO 10 IP=1,NPLEN                                                       WROUT.54    
         ILAB=IPOS+IP                                                        WROUT.55    
         WRITE(NCEC,'(/,A19,I5,A11,I5,A10)') ' TRAJECTORY NUMBER '           TRAJFORM.2     
     :        ,IP,' COMPRISES ',(IPTS-1)/NSKIP,' INTERVALS'                  WROUT.57    
         WRITE(NCEC,'(/,A)')                                                 WROUT.58    
     :' STEP    HOURS  LAT          LON          P (MB)      ATTRIBUTES'     TRAJFORM.3     
         DO 20 ITIME=1,IPTS,NSKIP                                            WROUT.60    
            POINTS(1)=POSN(ITIME,ILAB,2)*180./PI                             WROUT.61    
            POINTS(2)=POSN(ITIME,ILAB,1)*180./PI                             WROUT.62    
            IF (LPOUT) THEN                                                  WROUT.63    
               POINTS(3)=VPOSN(ITIME,ILAB)*1000.                             WROUT.64    
            ELSE                                                             WROUT.65    
               POINTS(3)=POSN(ITIME,ILAB,3)*1000.                            WROUT.66    
            ENDIF                                                            WROUT.67    
            IF (NATTR.GT.0) THEN                                             WROUT.68    
               DO 30 IATTR=1,NATTR                                           WROUT.69    
                  POINTS(3+IATTR)=POSN(ITIME,ILAB,3+IATTR)                   WROUT.70    
 30            CONTINUE                                                      WROUT.71    
            ENDIF                                                            WROUT.72    
            ISTEP=(ITIME-1)*NSTEPS/NJUMP                                     WROUT.73    
            AH=(ITIME-1)*THIST*24./FLOAT(NJUMP)                              WROUT.74    
            IF (.NOT.LFORW) AH=-AH                                           WROUT.75    
            WRITE(NCEC,1000) ISTEP,AH,(POINTS(I),I=1,NFPPAR)                 WROUT.76    
 20      CONTINUE                                                            WROUT.77    
 10   CONTINUE                                                               WROUT.78    
C                                                                            WROUT.79    
      CLOSE(NCEC)                                                            WROUT.80    
C                                                                            WROUT.81    
      RETURN                                                                 WROUT.82    
      END                                                                    WROUT.83    
C     ****************************************************************       WROUT.84    
      SUBROUTINE WRBIN                                                       WRBIN.2     
C                                                                            WRBIN.3     
C     Writes trajectory data held in array POSN to a file NCBIN.             WRBIN.4     
C     Can output pressure as the vertical coordinate.                        WRBIN.5     
C                                                                            WRBIN.6     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/CLUSTERS/NCLUSTERS,IPOSN(MAXCLUS)                               CLUSTERS.2     
     :,IPOINTER(MAXCLUS)                                                     BUGS3EC.3     
     :,XCLUSTER(MAXCLUS),YCLUSTER(MAXCLUS),ZCLUSTER(MAXCLUS)                 CLUSTERS.3     
     :,XSPACE(MAXCLUS),YSPACE(MAXCLUS),ZSPACE(MAXCLUS)                       CLUSTERS.4     
     :,NXACR(MAXCLUS),NYACR(MAXCLUS),PHILIM,INISURF                          CLUSTERS.5     
C                                                                            CLUSTERS.6     
      INTEGER KFORW                                                          WRBIN.13    
C                                                                            WRBIN.14    
C     Change the units of the coordinates to conform with the                WRBIN.15    
C     standard. (T:days, long,lat:degrees, levels:1000.*ALEV)                WRBIN.16    
C                                                                            WRBIN.17    
C     LPOUT switches from output in eta coordinate to output                 WRBIN.18    
C     in pressure coordinate.                                                WRBIN.19    
C                                                                            WRBIN.20    
      IF (LPOUT) THEN                                                        WRBIN.21    
         DO 10 ILAB=1,NPART                                                  WRBIN.22    
            DO 20 NTIME=1,IPTS                                               WRBIN.23    
               POSN(NTIME,ILAB,1)=POSN(NTIME,ILAB,1)*180./PI                 WRBIN.24    
               POSN(NTIME,ILAB,2)=POSN(NTIME,ILAB,2)*180./PI                 WRBIN.25    
               POSN(NTIME,ILAB,3)=VPOSN(NTIME,ILAB)*1000.                    WRBIN.26    
 20         CONTINUE                                                         WRBIN.27    
 10      CONTINUE                                                            WRBIN.28    
      ELSE                                                                   WRBIN.29    
         DO 110 ILAB=1,NPART                                                 WRBIN.30    
            DO 120 NTIME=1,IPTS                                              WRBIN.31    
               POSN(NTIME,ILAB,1)=POSN(NTIME,ILAB,1)*180./PI                 WRBIN.32    
               POSN(NTIME,ILAB,2)=POSN(NTIME,ILAB,2)*180./PI                 WRBIN.33    
               POSN(NTIME,ILAB,3)=POSN(NTIME,ILAB,3)*1000.                   WRBIN.34    
 120        CONTINUE                                                         WRBIN.35    
 110     CONTINUE                                                            WRBIN.36    
      ENDIF                                                                  WRBIN.37    
C                                                                            WRBIN.38    
C     Write the output .bin file.                                            WRBIN.39    
C                                                                            WRBIN.40    
      IF (LFORW) THEN                                                        WRBIN.41    
         KFORW=1                                                             WRBIN.42    
      ELSE                                                                   WRBIN.43    
         KFORW=0                                                             WRBIN.44    
      ENDIF                                                                  WRBIN.45    
      WRITE(NCBIN,'(5I8)') NPART,NCLUSTERS,IPTS,NATTR,KFORW                  WRBIN.46    
      WRITE(NCBIN,'(2E13.5)') BEGDAY,THIST                                   WRBIN.47    
      WRITE(NCBIN,'(5E13.5)') POSN                                           WRBIN.48    
C                                                                            WRBIN.49    
      RETURN                                                                 WRBIN.50    
      END                                                                    WRBIN.51    
C     ****************************************************************       WRBIN.52    
      SUBROUTINE INITAL                                                      INITAL.2     
C                                                                            INITAL.3     
C     Initialise program.                                                    INITAL.4     
C                                                                            INITAL.5     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
C                                                                            PATH.2     
C     Must ensure that NSTSAV >= NSTEPS.                                     PATH.3     
C                                                                            PATH.4     
      PARAMETER(NSTSAV=120)                                                  JOBID.13    
      COMMON/PATH/YP(NSTSAV,3)                                               PATH.6     
C                                                                            PATH.7     
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)                                       COMPSG.2     
C      PARAMETER(IGDLAP=1,IGCP=IGC)                                          COMPSG.3     
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)             COMPSG.4     
     :,BLETAM(IGCP,JG)                                                       SFCDATA.14    
C                                                                            COMPSG.5     
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/CLUSTERS/NCLUSTERS,IPOSN(MAXCLUS)                               CLUSTERS.2     
     :,IPOINTER(MAXCLUS)                                                     BUGS3EC.3     
     :,XCLUSTER(MAXCLUS),YCLUSTER(MAXCLUS),ZCLUSTER(MAXCLUS)                 CLUSTERS.3     
     :,XSPACE(MAXCLUS),YSPACE(MAXCLUS),ZSPACE(MAXCLUS)                       CLUSTERS.4     
     :,NXACR(MAXCLUS),NYACR(MAXCLUS),PHILIM,INISURF                          CLUSTERS.5     
C                                                                            CLUSTERS.6     
C                                                                            INITAL.15    
C     Set channel numbers.                                                   INITAL.16    
C                                                                            INITAL.17    
      DATA                                                                   INITAL.18    
     : LOUTP/6/,INPUT/20/,INPUT2/21/,NCBIN/2/,NCEC/14/,NCINTRAJ/12/          INITAL.19    
C                                                                            INITAL.20    
C     Default values for namelist INPNAME.                                   INITAL.21    
C                                                                            INITAL.22    
      DATA                                                                   INITAL.23    
     : BEGDAY,THIST,TRELEASE,TINTEG,IUVFORMAT/0.,0.25,0.25,1.,0/             INITAL.24    
     :,LMULTI/.FALSE./,LSPECTRAL/.TRUE./,ILEVTYPE/0/,IWORDSIZE/8/            INITAL.25    
     :,AKAP,GA,RDGAS,RADEA,WW,P0/.286,9.81,287.,6.371E6,7.292E-5,1.E5/       INITAL.26    
     :,LTRACSWITCH/.FALSE./                                                  INITAL.27    
     :,IATTRTYP/MAXATTR*0/,NCHI/1,2/,LPOUT/.FALSE./                          INITAL.28    
     :,NSTEPS/10/,LFORW/.TRUE./,LEVERY/.FALSE./,NSKIP/1/                     INITAL.29    
      NAMELIST/INPNAME/BEGDAY,THIST,TRELEASE,TINTEG,IUVFORMAT                INPNAME.2     
     :,LMULTI,LSPECTRAL,ILEVTYPE,IWORDSIZE                                   INPNAME.3     
     :,AKAP,GA,RADEA,WW,P0,RDGAS                                             INPNAME.4     
     :,LTRACSWITCH,KOLOUR                                                    INPNAME.5     
     :,IATTRTYP,NCHI,LPOUT,LEVERY,NSKIP                                      INPNAME.6     
     :,NSTEPS,LFORW                                                          INPNAME.7     
C                                                                            INPNAME.8     
C                                                                            INITAL.31    
C     Default values for namelist CLUSNAME.                                  INITAL.32    
C                                                                            INITAL.33    
      DATA                                                                   INITAL.34    
     : NCLUSTERS/1/,IPOSN/MAXCLUS*0/                                         INITAL.35    
     :,XCLUSTER/MAXCLUS*30./,YCLUSTER/MAXCLUS*45./                           INITAL.36    
     :,ZCLUSTER/MAXCLUS*0.5/,XSPACE/MAXCLUS*1./,YSPACE/MAXCLUS*1./           INITAL.37    
     :,ZSPACE/MAXCLUS*0.05/,NXACR/MAXCLUS*1/,NYACR/MAXCLUS*1/                INITAL.38    
     :,PHILIM/0./,INISURF/0/                                                 INITAL.39    
     :,IPOINTER/MAXCLUS*0/                                                   BUGS3EC.4     
      NAMELIST/CLUSNAME/NCLUSTERS,IPOSN,XCLUSTER,YCLUSTER,ZCLUSTER           CLUSNAME.2     
     :,XSPACE,YSPACE,ZSPACE,NXACR,NYACR,PHILIM,INISURF                       CLUSNAME.3     
C                                                                            CLUSNAME.4     
C                                                                            INITAL.41    
C     Default values for namelist DATENAME.                                  INITAL.42    
C                                                                            INITAL.43    
      DATA                                                                   INITAL.44    
     : ISYY/96/,ISMM/01/,ISDD/01/,ISHH/00/                                   INITAL.45    
     :,NRECPFILE/1/,IOFFOUT/5/,FSTEMO/'ec2d'/                                INITAL.46    
      NAMELIST/DATENAME/ISYY,ISMM,ISDD,ISHH,NRECPFILE,IOFFOUT,FSTEMO         DATENAME.2     
C                                                                            DATENAME.3     
C                                                                            INITAL.48    
C     Default values for namelist GRIBNAME.                                  INITAL.49    
C                                                                            INITAL.50    
      DATA                                                                   INITAL.51    
     : FSTEM/'siua'/,FSTEM2/'giua'/                                          INITAL.52    
     :,IOFFSET/5/,LERA/.FALSE./,IDATADATE/96010100/                          INITAL.53    
     :,FSTEM3/'sfam'/,IGRIBV/1/                                              SFCDATA.107   
      NAMELIST/GRIBNAME/IOFFSET,FSTEM,FSTEM2,LERA,IDATADATE                  GRIBNAME.2     
     :,FSTEM3,IGRIBV                                                         SFCDATA.15    
C                                                                            GRIBNAME.3     
C                                                                            INITAL.55    
C     Default values for namelist RSNAME.                                    INITAL.56    
C                                                                            INITAL.57    
      DATA                                                                   INITAL.58    
     : RNTAPE/1./,TSPD/48./,LDRY/.TRUE./,LT3D/.TRUE./                        INITAL.59    
      NAMELIST/RSNAME/RNTAPE,TSPD,LDRY,LT3D                                  RSNAME.2     
C     ********************************************************************   RSNAME.3     
C                                                                            INITAL.61    
C     Read namelists.                                                        INITAL.62    
C                                                                            INITAL.63    
      WRITE(LOUTP,*) 'Reading namelist INPNAME.'                             BUGS3EC.5     
      READ(5,INPNAME)                                                        INITAL.64    
      WRITE(LOUTP,*) 'Reading namelist CLUSNAME.'                            BUGS3EC.6     
      READ(5,CLUSNAME)                                                       INITAL.65    
      WRITE(LOUTP,*) 'Reading namelist DATENAME.'                            BUGS3EC.7     
      READ(5,DATENAME)                                                       INITAL.66    
      WRITE(LOUTP,*) 'Reading namelist GRIBNAME.'                            BUGS3EC.8     
      READ(5,GRIBNAME)                                                       INITAL.67    
      WRITE(LOUTP,*) 'Reading namelist RSNAME.'                              BUGS3EC.9     
      READ(5,RSNAME)                                                         INITAL.68    
C                                                                            INITAL.69    
C     Checks on compatibility of parameters and namelist controls.           INITAL.70    
C     Output interpretation of namelist controls to channel LOUTP.           INITAL.71    
C                                                                            INITAL.72    
      IF (IWORDSIZE.EQ.8) THEN                                               INITAL.73    
         WRITE(LOUTP,*)                                                      INITAL.74    
     :        'IWORDSIZE set for 64-bit computer (e.g. CRAY).'               INITAL.75    
      ELSE                                                                   INITAL.76    
         IF (IWORDSIZE.EQ.4) THEN                                            INITAL.77    
            WRITE(LOUTP,*)                                                   INITAL.78    
     :        'IWORDSIZE set for 32-bit computer (e.g. workstation).'        INITAL.79    
         ELSE                                                                INITAL.80    
            WRITE(LOUTP,*)                                                   INITAL.81    
     :        '****WARNING**** unexpected value for IWORDSIZE.'              INITAL.82    
         ENDIF                                                               INITAL.83    
      ENDIF                                                                  INITAL.84    
      IF (IUVFORMAT.EQ.0) THEN                                               INITAL.85    
         WRITE(LOUTP,*) 'Expecting ECMWF wind data.'                         INITAL.86    
      ELSE IF (IUVFORMAT.EQ.1) THEN                                          INITAL.87    
         WRITE(LOUTP,*) 'Expecting Reading spectral model history.'          INITAL.88    
      ELSE IF (IUVFORMAT.EQ.2) THEN                                          INITAL.89    
         WRITE(LOUTP,*) 'Expecting UKMO Unified Model data.'                 INITAL.90    
      ENDIF                                                                  INITAL.91    
      IF ((IUVFORMAT.EQ.1).AND.(.NOT.LSPECTRAL)) THEN                        INITAL.92    
         WRITE(LOUTP,*) 'MUST SELECT LSPECTRAL=.TRUE. WHEN USING             INITAL.93    
     :        READING SPECTRAL DATA.'                                        INITAL.94    
         LSPECTRAL=.TRUE.                                                    INITAL.95    
      ENDIF                                                                  INITAL.96    
      IF (LSPECTRAL.AND.(IUVFORMAT.GT.1)) THEN                               INITAL.97    
         WRITE(LOUTP,*) 'MUST SELECT LSPECTRAL=.FALSE. WHEN NOT USING        INITAL.98    
     :         ECMWF OR READING SPECTRAL DATA.'                              INITAL.99    
         LSPECTRAL=.FALSE.                                                   INITAL.100   
      ENDIF                                                                  INITAL.101   
C                                                                            Y2K.3     
C     Set LYRNAM=.T. to include the year in directory path for input.        Y2K.4     
C                                                                            Y2K.5     
      LYRNAM=.FALSE.                                                         Y2K.6     
C                                                                            INITAL.102   
C     Determine gridtype and vertical coordinate.                            INITAL.103   
C                                                                            INITAL.104   
C     Vertical coordinate in which particles are advected must               INITAL.105   
C     be compatible with supplied vertical velocity.                         INITAL.106   
C                                                                            INITAL.107   
      IF (LSPECTRAL) THEN                                                    INITAL.108   
         IGRIDTYPE=0                                                         INITAL.109   
         WRITE(LOUTP,*) 'Using GAUSSIAN grid.'                               INITAL.110   
         LEVZT1=.TRUE.                                                       INITAL.111   
         WRITE(LOUTP,*) 'Assuming levels ordered from top to ground.'        INITAL.112   
         ILEVTYPE=0                                                          INITAL.113   
         WRITE(LOUTP,*) 'ASSUME SPECTRAL DATA TO BE ON ETA LEVELS.'          INITAL.114   
         LOROG=.FALSE.                                                       INITAL.115   
      ELSE                                                                   INITAL.116   
         IGRIDTYPE=1                                                         INITAL.117   
         WRITE(LOUTP,*) 'Assuming data on a REGULAR LAT-LON grid.'           INITAL.118   
         IF (IUVFORMAT.EQ.0) THEN                                            INITAL.119   
            LEVZT1=.FALSE.                                                   INITAL.120   
            WRITE(LOUTP,*)                                                   INITAL.121   
     :           'Assuming levels ordered from ground to top.'               INITAL.122   
            ILEVTYPE=1                                                       INITAL.123   
            WRITE(LOUTP,*)                                                   INITAL.124   
     :           'Assuming ECMWF gridded data is on PRESSURE levels.'        INITAL.125   
            LOROG=.TRUE.                                                     INITAL.126   
            WRITE(LOUTP,*)                                                   INITAL.127   
     :           'Must supply OROGRAPHY in file FSTEM2.'                     INITAL.128   
         ELSE                                                                INITAL.129   
            LEVZT1=.TRUE.                                                    INITAL.130   
            WRITE(LOUTP,*)                                                   INITAL.131   
     :           'Levels re-ordered from top to ground when read in.'        INITAL.132   
            LOROG=.FALSE.                                                    INITAL.133   
            WRITE(LOUTP,*) 'Must supply surface pressure field.'             INITAL.134   
         ENDIF                                                               INITAL.135   
         IF (ILEVTYPE.EQ.0) THEN                                             INITAL.136   
            WRITE(LOUTP,*) 'Reading data on eta-levels.'                     INITAL.137   
         ELSE                                                                INITAL.138   
            IF (ILEVTYPE.EQ.1) THEN                                          INITAL.139   
               WRITE(LOUTP,*) 'Reading data on pressure levels.'             INITAL.140   
            ENDIF                                                            INITAL.141   
            IF (ILEVTYPE.EQ.2) THEN                                          INITAL.142   
               WRITE(LOUTP,*) '****WARNING****'                              INITAL.143   
               WRITE(LOUTP,*) 'ILEVTYPE=2 currently not supported.'          INITAL.144   
            ENDIF                                                            INITAL.145   
            IF (LPOUT) THEN                                                  INITAL.146   
               WRITE(LOUTP,*) 'SETTING LPOUT=.FALSE. SINCE PRESSURE IS       INITAL.147   
     :              OUTPUT AS THE DEFAULT WHEN ILEVTYPE IS NOT ZERO.'        INITAL.148   
               LPOUT=.FALSE.                                                 INITAL.149   
            ENDIF                                                            INITAL.150   
         ENDIF                                                               INITAL.151   
      ENDIF                                                                  INITAL.152   
C                                                                            INITAL.153   
C     Check for backward trajectories.                                       INITAL.154   
C                                                                            INITAL.155   
      WRITE(LOUTP,*)' '                                                      INITAL.156   
      IF (LFORW) THEN                                                        INITAL.157   
         WRITE(LOUTP,*)'FORWARD TRAJECTORIES.'                               INITAL.158   
      ELSE                                                                   INITAL.159   
         WRITE(LOUTP,*)'BACK TRAJECTORIES.'                                  INITAL.160   
      ENDIF                                                                  INITAL.161   
      IF ((.NOT.LFORW).AND.(NRECPFILE.GT.1).AND.(IUVFORMAT.NE.2)) THEN       INITAL.162   
         WRITE(LOUTP,*) '***WARNING*** The wind records must be              INITAL.163   
     :   ordered in reverse for back trajectory calculations.'               INITAL.164   
      ENDIF                                                                  INITAL.165   
      NCDATE=ISYY*1000000+ISMM*10000+ISDD*100+ISHH                           INITAL.166   
      IF (NCDATE.GT.IDATADATE) THEN                                          INITAL.167   
         WRITE(LOUTP,*)'Using wind data forecast on ',IDATADATE              INITAL.168   
      ELSE                                                                   INITAL.169   
         WRITE(LOUTP,*)'Using archived wind data.'                           INITAL.170   
      ENDIF                                                                  INITAL.171   
      KYY=ISYY                                                               SFCDATA.108   
      KMM=ISMM                                                               SFCDATA.109   
      KDD=ISDD                                                               SFCDATA.110   
      KHH=ISHH                                                               SFCDATA.111   
      IDATE=KYY*1000000+KMM*10000+KDD*100+KHH                                SFCDATA.112   
      IF (IDATE.GT.IDATADATE) THEN                                           SFCDATA.113   
         WRITE(LOUTP,*) ' Starting from a forecast.'                         SFCDATA.114   
         LFORC=.TRUE.                                                        SFCDATA.115   
      ELSE                                                                   SFCDATA.116   
         WRITE(LOUTP,*) ' Starting from an analysis.'                        SFCDATA.117   
         LFORC=.FALSE.                                                       SFCDATA.118   
      ENDIF                                                                  SFCDATA.119   
C                                                                            INITAL.172   
C     Check on intermediate trajectory saving operation.                     INITAL.173   
C                                                                            INITAL.174   
      IF (NSTSAV.LT.NSTEPS) THEN                                             INITAL.175   
         WRITE(LOUTP,*)'NSTSAV must be >= NSTEPS.'                           INITAL.176   
         WRITE(LOUTP,*)'NSTSAV = ',NSTSAV,'    NSTEPS = ',NSTEPS             INITAL.177   
         STOP                   90                                           INITAL.178   
      ENDIF                                                                  INITAL.179   
      IF(LEVERY) THEN                                                        INITAL.180   
         WRITE(LOUTP,*)'Trajectories recorded after every time-step.'        INITAL.181   
         REM=FLOAT(IPTS-1)/FLOAT(NSTEPS)-(IPTS-1)/NSTEPS                     INITAL.182   
         IF (REM.GT.1.E-7) THEN                                              INITAL.183   
            WRITE(LOUTP,*)                                                   INITAL.184   
     :           'IPTS-1 must be an integer multiple of NSTEPS.'             INITAL.185   
            WRITE(LOUTP,*)'NSTEPS = ',NSTEPS,'    IPTS = ',IPTS              INITAL.186   
            STOP                   91                                        INITAL.187   
         ENDIF                                                               INITAL.188   
         WRITE(LOUTP,*)'Trajectories output every '                          INITAL.189   
     :        ,NSKIP*THIST/NSTEPS,' days.'                                   INITAL.190   
         NHISTS=(IPTS-1)/NSTEPS+1                                            INITAL.191   
         NJUMP=NSTEPS                                                        INITAL.192   
      ELSE                                                                   INITAL.193   
         WRITE(LOUTP,*)'Trajectories recorded at time interval THIST.'       INITAL.194   
         WRITE(LOUTP,*)'Trajectories output every '                          INITAL.195   
     :        ,NSKIP*THIST,' days.'                                          INITAL.196   
         NHISTS=IPTS                                                         INITAL.197   
         NJUMP=1                                                             INITAL.198   
      ENDIF                                                                  INITAL.199   
C                                                                            INITAL.200   
C     Check on parallel trajectory set operation.                            INITAL.201   
C                                                                            INITAL.202   
      RECINT=(NHISTS-1)*THIST                                                INITAL.203   
      IF (LMULTI) THEN                                                       INITAL.204   
         WRITE(LOUTP,*)                                                      INITAL.205   
     :    'Parallel trajectory sets run with staggered release times.'       INITAL.206   
         REM=TRELEASE/THIST-INT(TRELEASE/THIST)                              INITAL.207   
         IF ((REM.NE.0).OR.(TRELEASE.EQ.0)) THEN                             INITAL.208   
            WRITE(LOUTP,*)                                                   INITAL.209   
     :           'TRELEASE should be an integer multiple of THIST.'          INITAL.210   
            STOP                100                                          INITAL.211   
         ENDIF                                                               INITAL.212   
         REM=RECINT/TRELEASE-INT(RECINT/TRELEASE)                            INITAL.213   
         IF ((REM.NE.0).OR.(RECINT.EQ.0)) THEN                               INITAL.214   
            WRITE(LOUTP,*)                                                   INITAL.215   
     :           'RECINT should be an integer multiple of TRELEASE.'         INITAL.216   
            STOP                101                                          INITAL.217   
         ENDIF                                                               INITAL.218   
         REM=TINTEG/THIST-INT(TINTEG/THIST)                                  INITAL.219   
         IF ((REM.NE.0).OR.(TINTEG.LT.(RECINT+TRELEASE))) THEN               INITAL.220   
            WRITE(LOUTP,*)                                                   INITAL.221   
     :       'THIST=',THIST,'  TINTEG=',TINTEG,'  RECINT=',RECINT            INITAL.222   
            WRITE(LOUTP,*)                                                   INITAL.223   
     :       'TINTEG should be an integer multiple of THIST.'                INITAL.224   
            WRITE(LOUTP,*)                                                   INITAL.225   
     :       'TINTEG should also be >= RECINT+TRELEASE.'                     INITAL.226   
            STOP                102                                          INITAL.227   
         ENDIF                                                               INITAL.228   
         NSETS=NINT(RECINT/TRELEASE)                                         INITAL.229   
         WRITE(LOUTP,*) NSETS,' sets of trajectories at any one time.'       INITAL.230   
         RNPART=FLOAT(NPART)                                                 INITAL.231   
         REM=RNPART*TRELEASE/RECINT-NPART/NSETS                              INITAL.232   
         IF (REM.GT.0.00001) THEN                                            INITAL.233   
            WRITE(LOUTP,*) 'NPART should be a multiple of NSETS.'            INITAL.234   
            WRITE(LOUTP,*) 'REM = ',REM                                      INITAL.235   
            STOP                103                                          INITAL.236   
         ENDIF                                                               INITAL.237   
         NPSET=NPART/NSETS                                                   INITAL.238   
         WRITE(LOUTP,*) NPSET,' trajectories per set.'                       INITAL.239   
      ELSE                                                                   INITAL.240   
         WRITE(LOUTP,*) 'All trajectories released at the same time.'        INITAL.241   
         TINTEG=RECINT                                                       INITAL.242   
         TRELEASE=RECINT                                                     INITAL.243   
         NSETS=1                                                             INITAL.244   
         NPSET=NPART                                                         INITAL.245   
      ENDIF                                                                  INITAL.246   
C                                                                            INITAL.247   
C     Checks on initial positions.                                           INITAL.248   
C                                                                            INITAL.249   
      NPTEST=0                                                               INITAL.250   
      DO 10 ICL=1,NCLUSTERS                                                  INITAL.251   
         WRITE(LOUTP,*) 'CLUSTER ',ICL                                       INITAL.252   
         IF (IPOSN(ICL).EQ.0) THEN                                           INITAL.253   
            WRITE(LOUTP,*) 'No initial arrangement for cluster.'             INITAL.254   
            STOP                   2                                         INITAL.255   
         ENDIF                                                               INITAL.256   
         IF (IPOSN(ICL).EQ.1) THEN                                           INITAL.257   
            NIDEAL=MG*JG*NCLUSTERS*NHEM                                      INITAL.258   
            WRITE(LOUTP,*) NIDEAL                                            INITAL.259   
     :           ,' particles to start on every gridpoint.'                  INITAL.260   
            NPTEST=NPTEST+NIDEAL                                             INITAL.261   
         ENDIF                                                               INITAL.262   
         IF (IPOSN(ICL).EQ.2) THEN                                           INITAL.263   
            NIDEAL=((MG+1)/2)*((JG+1)/2)*NCLUSTERS*NHEM                      INITAL.264   
            WRITE(LOUTP,*) NIDEAL                                            INITAL.265   
     :           ,' particles to start on every other gridpoint.'            INITAL.266   
            NPTEST=NPTEST+NIDEAL                                             INITAL.267   
         ENDIF                                                               INITAL.268   
         IF (IPOSN(ICL).EQ.3) THEN                                           INITAL.269   
            NIDEAL=NXACR(ICL)*NYACR(ICL)                                     INITAL.270   
            WRITE(LOUTP,*) NIDEAL                                            INITAL.271   
     :           ,' particles in regular lon-lat rectangle.'                 INITAL.272   
            NPTEST=NPTEST+NIDEAL                                             INITAL.273   
         ENDIF                                                               INITAL.274   
         IF (IPOSN(ICL).EQ.4) THEN                                           INITAL.275   
            NIDEAL=NXACR(ICL)*NYACR(ICL)                                     INITAL.276   
            WRITE(LOUTP,*) NIDEAL                                            INITAL.277   
     :           ,' particles in regular lon-sin(lat) rectangle.'            INITAL.278   
            NPTEST=NPTEST+NIDEAL                                             INITAL.279   
         ENDIF                                                               INITAL.280   
         IF (IPOSN(ICL).EQ.5) THEN                                           INITAL.281   
            NIDEAL=7                                                         INITAL.282   
            WRITE(LOUTP,*) NIDEAL                                            INITAL.283   
     :           ,' particles in 3-D ball.'                                  INITAL.284   
            NPTEST=NPTEST+NIDEAL                                             INITAL.285   
            IF (INISURF.GT.0) THEN                                           INITAL.286   
               WRITE(LOUTP,*) 'SETTING INISURF=0 FOR BALL CLUSTERS.'         INITAL.287   
               INISURF=0                                                     INITAL.288   
            ENDIF                                                            INITAL.289   
         ENDIF                                                               INITAL.290   
         IF (IPOSN(ICL).EQ.6) THEN                                           INITAL.291   
            NIDEAL=NPSET/NCLUSTERS                                           INITAL.292   
            WRITE(LOUTP,*) NIDEAL                                            INITAL.293   
     :           ,' particles homogeneously spread on stereographic.'        INITAL.294   
            NPTEST=NPTEST+NIDEAL                                             INITAL.295   
            IF (MOCT.LT.2) THEN                                              INITAL.296   
               WRITE(LOUTP,*) 'MOCT > 1 for this arrangement.'               INITAL.297   
               STOP          3                                               INITAL.298   
            ENDIF                                                            INITAL.299   
         ENDIF                                                               INITAL.300   
         IF (IPOSN(ICL).EQ.7) THEN                                           INITAL.301   
            NIDEAL=NPSET                                                     INITAL.302   
            WRITE(LOUTP,*) NIDEAL                                            INITAL.303   
     :           ,' particles restarted from an old record.'                 INITAL.304   
            NPTEST=NPTEST+NIDEAL                                             INITAL.305   
            IF (NCLUSTERS.GT.1) THEN                                         INITAL.306   
               WRITE(LOUTP,*) 'NCLUSTERS=1 for this arrangement.'            INITAL.307   
               STOP          4                                               INITAL.308   
            ENDIF                                                            INITAL.309   
         ENDIF                                                               INITAL.310   
         IF (IPOSN(ICL).EQ.9) THEN                                           ZATTR.2     
            NIDEAL=NPSET/NCLUSTERS                                           ZATTR.3     
            WRITE(LOUTP,*) NIDEAL                                            ZATTR.4     
     :           ,' particles in column above release point.'                ZATTR.5     
            IF (INISURF.NE.0) THEN                                           ZATTR.6     
               WRITE(LOUTP,*)                                                ZATTR.7     
     :           'Setting INISURF=0 for release from model levels.'          ZATTR.8     
               INISURF=0                                                     ZATTR.9     
            ENDIF                                                            ZATTR.10    
            NPTEST=NPTEST+NIDEAL                                             ZATTR.11    
         ENDIF                                                               ZATTR.12    
 10   CONTINUE                                                               INITAL.311   
      IF (NPTEST.NE.NPSET) THEN                                              INITAL.312   
         WRITE(LOUTP,*) 'Number of particles per set is not equal to'        INITAL.313   
         WRITE(LOUTP,*) 'the sum of those in each cluster.'                  INITAL.314   
         WRITE(LOUTP,*) 'SUM = ',NPTEST,'      NPSET = ',NPSET               INITAL.315   
         STOP                5                                               INITAL.316   
      ENDIF                                                                  INITAL.317   
      IF (INISURF.EQ.0) THEN                                                 INITAL.318   
         WRITE(LOUTP,*) 'Placing particles on model levels.'                 INITAL.319   
      ENDIF                                                                  INITAL.320   
      IF (INISURF.EQ.1) THEN                                                 INITAL.321   
         WRITE(LOUTP,*) 'Placing particles on pressure surfaces.'            INITAL.322   
         IF (ILEVTYPE.NE.0) THEN                                             INITAL.323   
C                                                                            INITAL.324   
C     Pressure is used as the particles' vertical coordinate                 INITAL.325   
C     (rather than eta).                                                     INITAL.326   
C                                                                            INITAL.327   
            INISURF=0                                                        INITAL.328   
         ENDIF                                                               INITAL.329   
      ENDIF                                                                  INITAL.330   
      IF (INISURF.EQ.2) THEN                                                 INITAL.331   
         WRITE(LOUTP,*) 'Placing particles on theta surfaces.'               INITAL.332   
         WRITE(LOUTP,*) '****WARNING**** Must supply temperature!'           INITAL.333   
         LTATTR=.TRUE.                                                       INITAL.334   
      ELSE                                                                   INITAL.335   
         LTATTR=.FALSE.                                                      INITAL.336   
      ENDIF                                                                  INITAL.337   
C                                                                            INITAL.338   
C     Check on the existance of moisture and tracers in the                  INITAL.339   
C     history record, if required for assigning values to                    INITAL.340   
C     particle attributes.                                                   INITAL.341   
C                                                                            INITAL.342   
      LQATTR=.FALSE.                                                         INITAL.343   
      LPVATTR=.FALSE.                                                        INITAL.344   
      LSFCATTR=.FALSE.                                                       SFCDATA.120   
      IF (NATTR.GT.0) THEN                                                   INITAL.345   
         IF (LTRACSWITCH.AND.(IUVFORMAT.EQ.0)) THEN                          INITAL.346   
            WRITE(LOUTP,*) 'No tracers in ECMWF history files so             INITAL.347   
     :      should use LTRACSWITCH=.FALSE. .'                                INITAL.348   
            STOP                  7                                          INITAL.349   
         ENDIF                                                               INITAL.350   
         DO 20 IATTR=1,NATTR                                                 INITAL.351   
            IF(IATTRTYP(IATTR).EQ.100) THEN                                  PSIATTR.2     
               WRITE(LOUTP,*)'Attributing surface pressure.'                 INITAL.353   
            ENDIF                                                            INITAL.354   
            IF(IATTRTYP(IATTR).EQ.1) THEN                                    INITAL.355   
               LTATTR=.TRUE.                                                 INITAL.356   
               WRITE(LOUTP,*)'Attributing temperature.'                      INITAL.357   
            ENDIF                                                            INITAL.358   
            IF(IATTRTYP(IATTR).EQ.2) THEN                                    INITAL.359   
               LTATTR=.TRUE.                                                 INITAL.360   
               WRITE(LOUTP,*)'Attributing potential temperature.'            INITAL.361   
            ENDIF                                                            INITAL.362   
            IF (IATTRTYP(IATTR).EQ.3) THEN                                   INITAL.363   
               LPVATTR=.TRUE.                                                INITAL.364   
               WRITE(LOUTP,*)'Attributing Ertel PV.'                         INITAL.365   
               IF(LSPECTRAL) THEN                                            INITAL.366   
                  LTATTR=.TRUE.                                              INITAL.367   
               ELSE                                                          INITAL.368   
                  WRITE(LOUTP,*)'****WARNING****'                            INITAL.369   
                  WRITE(LOUTP,*)                                             INITAL.370   
     :              'PV must be provided as a field in data record.'         INITAL.371   
               ENDIF                                                         INITAL.372   
            ENDIF                                                            INITAL.373   
            IF(IATTRTYP(IATTR).EQ.4) THEN                                    INITAL.374   
               LQATTR=.TRUE.                                                 INITAL.375   
               WRITE(LOUTP,*)'Attributing moisture variable.'                INITAL.376   
               IF ((IUVFORMAT.EQ.1).AND.LDRY) THEN                           INITAL.377   
                  WRITE(LOUTP,*)'No moisture in history file so cannot       INITAL.378   
     :            assign a specific humidity as an attribute.'               INITAL.379   
                  STOP               8                                       INITAL.380   
               ENDIF                                                         INITAL.381   
            ENDIF                                                            INITAL.382   
            IF(IATTRTYP(IATTR).EQ.142) THEN                                  SFCDATA.121   
               LSFCATTR=.TRUE.                                               SFCDATA.122   
               WRITE(LOUTP,*)'Attributing stratiform precipitation.'         SFCDATA.123   
            ENDIF                                                            SFCDATA.124   
            IF(IATTRTYP(IATTR).EQ.143) THEN                                  SFCDATA.125   
               LSFCATTR=.TRUE.                                               SFCDATA.126   
               WRITE(LOUTP,*)'Attributing convective precipitation.'         SFCDATA.127   
            ENDIF                                                            SFCDATA.128   
            IF(IATTRTYP(IATTR).EQ.159) THEN                                  SFCDATA.129   
               LSFCATTR=.TRUE.                                               SFCDATA.130   
               WRITE(LOUTP,*)'Attributing BL height.'                        SFCDATA.131   
            ENDIF                                                            SFCDATA.132   
            IF(IATTRTYP(IATTR).EQ.167) THEN                                  SFCDATA.133   
               LSFCATTR=.TRUE.                                               SFCDATA.134   
               WRITE(LOUTP,*)'Attributing T (2m).'                           SFCDATA.135   
            ENDIF                                                            SFCDATA.136   
            IF(IATTRTYP(IATTR).EQ.168) THEN                                  SFCDATA.137   
               LSFCATTR=.TRUE.                                               SFCDATA.138   
               WRITE(LOUTP,*)'Attributing T_dew (2m).'                       SFCDATA.139   
            ENDIF                                                            SFCDATA.140   
            IF(IATTRTYP(IATTR).EQ.182) THEN                                  SFCDATA.141   
               LSFCATTR=.TRUE.                                               SFCDATA.142   
               WRITE(LOUTP,*)'Attributing evaporation.'                      SFCDATA.143   
            ENDIF                                                            SFCDATA.144   
            IF(IATTRTYP(IATTR).EQ.186) THEN                                  SFCDATA.145   
               LSFCATTR=.TRUE.                                               SFCDATA.146   
               WRITE(LOUTP,*)'Attributing low level cloud.'                  SFCDATA.147   
            ENDIF                                                            SFCDATA.148   
            IF(IATTRTYP(IATTR).EQ.187) THEN                                  SFCDATA.149   
               LSFCATTR=.TRUE.                                               SFCDATA.150   
               WRITE(LOUTP,*)'Attributing medium level cloud.'               SFCDATA.151   
            ENDIF                                                            SFCDATA.152   
            IF(IATTRTYP(IATTR).EQ.188) THEN                                  SFCDATA.153   
               LSFCATTR=.TRUE.                                               SFCDATA.154   
               WRITE(LOUTP,*)'Attributing high level cloud.'                 SFCDATA.155   
            ENDIF                                                            SFCDATA.156   
            IF(IATTRTYP(IATTR).EQ.258) THEN                                  SFCDATA.157   
               LSFCATTR=.TRUE.                                               SFCDATA.158   
               WRITE(LOUTP,*)'Attributing photosynthetically AR.'            SFCDATA.159   
            ENDIF                                                            SFCDATA.160   
            IF(IATTRTYP(IATTR).EQ.5.AND.(.NOT.LTRACSWITCH)) THEN             INITAL.383   
               WRITE(LOUTP,*) 'No tracers in history file so cannot          INITAL.384   
     :         assign a tracer as an attribute.'                             INITAL.385   
               STOP               9                                          INITAL.386   
            ENDIF                                                            INITAL.387   
            IF(IATTRTYP(IATTR).EQ.6.AND.(NTRAC.LE.1)) THEN                   INITAL.388   
               WRITE(LOUTP,*) 'One tracer in history file so cannot          INITAL.389   
     :         assign a 2 tracers as attributes.'                            INITAL.390   
               STOP               10                                         INITAL.391   
            ENDIF                                                            INITAL.392   
            IF(IATTRTYP(IATTR).EQ.10) THEN                                   ZATTR.13    
               WRITE(LOUTP,*) 'Attributing height  (m).'                     ZATTR.14    
            ENDIF                                                            ZATTR.15    
 20      CONTINUE                                                            INITAL.393   
      ENDIF                                                                  INITAL.394   
      WRITE(LOUTP,*) ' '                                                     INITAL.395   
C                                                                            INITAL.396   
C     Dimensionalising factors and fundamental constants.                    INITAL.397   
C                                                                            INITAL.398   
      CV=RADEA*WW                                                            INITAL.399   
      CT=CV*CV/RDGAS                                                         INITAL.400   
      CQ=1000.                                                               INITAL.401   
      CERT=1.E6*CT*WW*GA/P0                                                  INITAL.402   
      IF (LTRACSWITCH) THEN                                                  INITAL.403   
         DO 30 I=1,NTRAC                                                     INITAL.404   
            CTRA(I)=1.                                                       INITAL.405   
            IF (KOLOUR(I).EQ.1) THEN                                         INITAL.406   
               CTRA(I)=CT                                                    INITAL.407   
            ENDIF                                                            INITAL.408   
            IF (KOLOUR(I).EQ.2) THEN                                         INITAL.409   
               CTRA(I)=CERT                                                  INITAL.410   
            ENDIF                                                            INITAL.411   
 30      CONTINUE                                                            INITAL.412   
      ENDIF                                                                  INITAL.413   
C                                                                            INITAL.414   
      DAY=BEGDAY                                                             INITAL.415   
C                                                                            INITAL.416   
C     Set channels for attribute scratch files.                              INITAL.417   
C                                                                            INITAL.418   
      DO 40 I=1,MAXATTR                                                      INITAL.419   
         NCGP(I)=39+I                                                        INITAL.420   
 40   CONTINUE                                                               INITAL.421   
C                                                                            INITAL.422   
C     First guess for grid point of first particle for hunt search.          INITAL.423   
C                                                                            INITAL.424   
      JSAV=JGG/2                                                             INITAL.425   
      LSAV=NL/2                                                              INITAL.426   
      LHSAV=NLM/2                                                            INITAL.427   
C                                                                            INITAL.428   
C     Put the longitudinal grid spacing as separate variable.                INITAL.429   
C     Already done for vert. and latitudinal spacing.                        INITAL.430   
C                                                                            INITAL.431   
      DLAM=PI2DM/MG                                                          INITAL.432   
C                                                                            INITAL.433   
C     Call set up routines which are specific to the format                  INITAL.434   
C     of the wind (and other attribute) data.                                INITAL.435   
C                                                                            INITAL.436   
      WRITE(LOUTP,*) ' IGRIBV, ILEVTYPE = ',IGRIBV,ILEVTYPE                  JOBID.4     
C      STOP 436                                                              JOBID.5     
      IF (IUVFORMAT.EQ.0) THEN                                               SFCDATA.161   
         IF (IGRIBV.EQ.1) THEN                                               SFCDATA.162   
            CALL INIGS                                                       SFCDATA.163   
         ELSE                                                                SFCDATA.164   
            CALL INIGS2                                                      SFCDATA.165   
         ENDIF                                                               SFCDATA.166   
      ENDIF                                                                  SFCDATA.167   
      IF (IUVFORMAT.EQ.1) CALL INIRS                                         INITAL.438   
      IF (IUVFORMAT.EQ.2) CALL INIUM                                         INITAL.439   
      IF (IUVFORMAT.EQ.3) CALL INIARB                                        INITAL.440   
C                                                                            INITAL.441   
      IF (IUVFORMAT.NE.2) THEN                                               INITAL.442   
         ZUBZX=-DLAM                                                         INITAL.443   
         ZTBZX=ZUBZX                                                         INITAL.444   
         DO 100 J=1,JGG                                                      INITAL.445   
            ALATT(J)=ALAT(J)                                                 INITAL.446   
 100     CONTINUE                                                            INITAL.447   
      ENDIF                                                                  INITAL.448   
C                                                                            INITAL.449   
      DO 110 IATTR=1,MAXATTR                                                 INITAL.450   
         LUGRID(IATTR)=.FALSE.                                               INITAL.451   
         IF ((IATTRTYP(IATTR).EQ.4).AND.(ILEVTYPE.EQ.1)                      INITAL.452   
     :       .AND.(IUVFORMAT.EQ.2)) THEN                                     INITAL.453   
            LUGRID(IATTR)=.TRUE.                                             INITAL.454   
         ENDIF                                                               INITAL.460   
 110  CONTINUE                                                               INITAL.461   
C                                                                            INITAL.462   
      IF ((IUVFORMAT.LE.1).AND.(ILEVTYPE.EQ.0)) THEN                         INITAL.463   
C                                                                            INITAL.464   
C     RGG matrix for vertical derivatives (used by DLSGCR):                  INITAL.465   
C     d()/dln(sigma) = (sigma)d()/d(sigma).                                  INITAL.466   
C                                                                            INITAL.467   
         IL=0                                                                INITAL.468   
         DO 120 L=1,NL                                                       INITAL.469   
            RGVAL=SIGMA(L)*0.5/DSIGMA(L)                                     INITAL.470   
            DO 122 M=1,NL                                                    INITAL.471   
               IL=IL+1                                                       INITAL.472   
               RGG(IL)=0.                                                    INITAL.473   
               IF (M.EQ.L-1) RGG(IL)=-RGVAL                                  INITAL.474   
               IF (M.EQ.L+1) RGG(IL)=RGVAL                                   INITAL.475   
 122        CONTINUE                                                         INITAL.476   
 120     CONTINUE                                                            INITAL.477   
         DA=SIGMA(1)                                                         INITAL.478   
         DB=SIGMA(2)-DA                                                      INITAL.479   
         DC=SIGMA(3)-SIGMA(2)                                                INITAL.480   
         DD=DC+DB                                                            INITAL.481   
         RGG(1)=-DA*(DD+DB)/(DB*DD)                                          INITAL.482   
         RGG(2)=DA*DD/(DB*DC)                                                INITAL.483   
         RGG(3)=-DA*DB/(DC*DD)                                               INITAL.484   
         DA=SIGMA(NL)                                                        INITAL.485   
         DD=SIGMA(NL-1)                                                      INITAL.486   
         DB=DA-DD                                                            INITAL.487   
         DC=DD-SIGMA(NL-2)                                                   INITAL.488   
         DD=DC+DB                                                            INITAL.489   
         RGG(NL2)=DA*(DD+DB)/(DB*DD)                                         INITAL.490   
         RGG(NL2-1)=-DA*DD/(DB*DC)                                           INITAL.491   
         RGG(NL2-2)=DA*DB/(DC*DD)                                            INITAL.492   
      ENDIF                                                                  INITAL.493   
C                                                                            INITAL.494   
C     Set the stepsize for the non-adaptive R-K scheme.                      INITAL.495   
C                                                                            INITAL.496   
      H1=THIST/REAL(NSTEPS)                                                  INITAL.497   
C                                                                            INITAL.498   
C     Set grid point wind fields to zero.                                    INITAL.499   
C                                                                            INITAL.500   
C                                                                            INITAL.501   
      DO 140 I=1,IGD                                                         INITAL.502   
         UG(I)=0.0                                                           INITAL.503   
         VG(I)=0.0                                                           INITAL.504   
         ZG(I)=0.0                                                           INITAL.505   
         DG(I)=0.0                                                           INITAL.506   
         TG(I)=0.0                                                           INITAL.507   
         TXG(I)=0.0                                                          INITAL.508   
         TYG(I)=0.0                                                          INITAL.509   
         SDOTG(I)=0.0                                                        INITAL.510   
         THG(I)=0.0                                                          INITAL.511   
         QG(I)=0.0                                                           INITAL.512   
         EPVG(I)=0.0                                                         INITAL.513   
 140   CONTINUE                                                              INITAL.514   
      DO 142 I=1,IGC                                                         INITAL.515   
         PLG(I)=0.0                                                          INITAL.516   
         PJG(I)=0.0                                                          INITAL.517   
         PMG(I)=0.0                                                          INITAL.518   
 142   CONTINUE                                                              INITAL.519   
      DO 150 I=1,IGDLA                                                       INITAL.520   
         URHS(I)=0.0                                                         INITAL.521   
         VRHS(I)=0.0                                                         INITAL.522   
         SDRHS(I)=0.0                                                        INITAL.523   
         THGLA(I)=0.0                                                        INITAL.524   
         W2ETA(I)=0.0                                                        ZATTR.16    
 150  CONTINUE                                                               INITAL.525   
      DO 160 J=1,JG                                                          INITAL.526   
         DO 170 I=1,IGC                                                      INITAL.527   
            PLGLA(I,J)=0.0                                                   INITAL.528   
            PRECIP(I,J)=0.0                                                  SFCDATA.168   
            PRECST(I,J)=0.0                                                  SFCDATA.169   
            EVAP(I,J)=0.0                                                    SFCDATA.170   
            BLHEIGHT(I,J)=0.0                                                SFCDATA.171   
            BLETA(I,J)=0.0                                                   SFCDATA.172   
            ALLC(I,J)=0.0                                                    SFCDATA.173   
            AMLC(I,J)=0.0                                                    SFCDATA.174   
            AHLC(I,J)=0.0                                                    SFCDATA.175   
            TEMP2M(I,J)=0.0                                                  SFCDATA.176   
            TDEW2M(I,J)=0.0                                                  SFCDATA.177   
            PCRAD(I,J)=0.0                                                   SFCDATA.178   
 170     CONTINUE                                                            INITAL.529   
 160  CONTINUE                                                               INITAL.530   
      IF(.NOT.LSPECTRAL) THEN                                                INITAL.531   
         DO 180 I=1,IGDLA                                                    INITAL.532   
            PSGLA(I)=0.0                                                     INITAL.533   
 180     CONTINUE                                                            INITAL.534   
      ENDIF                                                                  INITAL.535   
C                                                                            INITAL.536   
C     Set initial positions to zero.                                         INITAL.537   
C                                                                            INITAL.538   
      DO 200 I=1,NFPPAR                                                      INITAL.539   
         DO 205 ILAB=1,NPART                                                 INITAL.540   
            DO 210 ITIME=1,IPTS                                              INITAL.541   
               POSN(ITIME,ILAB,I)=0.0                                        INITAL.542   
 210        CONTINUE                                                         INITAL.543   
 205     CONTINUE                                                            INITAL.544   
 200  CONTINUE                                                               INITAL.545   
      IF (LPOUT) THEN                                                        INITAL.546   
         DO 220 ILAB=1,NPART                                                 INITAL.547   
            DO 225 ITIME=1,IPTS                                              INITAL.548   
               VPOSN(ITIME,ILAB)=0.0                                         INITAL.549   
 225        CONTINUE                                                         INITAL.550   
 220     CONTINUE                                                            INITAL.551   
      ENDIF                                                                  INITAL.552   
C                                                                            INITAL.553   
      RETURN                                                                 INITAL.554   
      END                                                                    INITAL.555   
C     ***************************************************************        INITAL.556   
      SUBROUTINE INIPOSN(IPOS,NTIME)                                         INIPOSN.2     
C                                                                            INIPOSN.3     
C     Initialise particle positions.                                         INIPOSN.4     
C                                                                            INIPOSN.5     
C     IPOS = marker for start of "mature" set.                               INIPOSN.6     
C     NTIME = denotes current time label for POSN.                           INIPOSN.7     
C                                                                            INIPOSN.8     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/CLUSTERS/NCLUSTERS,IPOSN(MAXCLUS)                               CLUSTERS.2     
     :,IPOINTER(MAXCLUS)                                                     BUGS3EC.3     
     :,XCLUSTER(MAXCLUS),YCLUSTER(MAXCLUS),ZCLUSTER(MAXCLUS)                 CLUSTERS.3     
     :,XSPACE(MAXCLUS),YSPACE(MAXCLUS),ZSPACE(MAXCLUS)                       CLUSTERS.4     
     :,NXACR(MAXCLUS),NYACR(MAXCLUS),PHILIM,INISURF                          CLUSTERS.5     
C                                                                            CLUSTERS.6     
      PARAMETER(IPTSB=1,NPARTB=1,NATTRB=0)                                   JOBID.14    
      REAL POSNB(IPTSB,NPARTB,3+NATTRB)                                      JOBID.15    
      REAL XCL,YCL,XSP,YSP,YTEMP,PHIL                                        INIPOSN.17    
      INTEGER NCL1,M,J,IPOS,NTIME,ILAB,ICL                                   INIPOSN.18    
C                                                                            INIPOSN.19    
      M=0                                                                    INIPOSN.20    
      J=0                                                                    INIPOSN.21    
      ILAB=IPOS                                                              INIPOSN.22    
      DO 10 ICL=1,NCLUSTERS                                                  INIPOSN.23    
         IF (IPOS.EQ.0) IPOINTER(ICL)=ILAB+1                                 BUGS3EC.10    
         IF (IPOSN(ICL).EQ.1) THEN                                           INIPOSN.24    
C                                                                            INIPOSN.25    
C     Initialise a particle on every g.p. in the horizontal                  INIPOSN.26    
C     and on levels given by ZCLUSTER. (NCL1=MG*JG*NCLUSTERS*NHEM)           INIPOSN.27    
C                                                                            INIPOSN.28    
            DO 110 J=1,JGG                                                   INIPOSN.29    
               DO 120 M=1,MG                                                 INIPOSN.30    
                  ILAB=ILAB+1                                                INIPOSN.31    
                  POSN(NTIME,ILAB,1)=ZTBZX+M*DLAM                            INIPOSN.32    
                  POSN(NTIME,ILAB,2)=ALATT(J)                                INIPOSN.33    
                  IF(INISURF.GT.0) THEN                                      INIPOSN.34    
                     CALL ONTHETA(ILAB,ICL,M,J,NTIME)                        INIPOSN.35    
                  ELSE                                                       INIPOSN.36    
                     POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)                        INIPOSN.37    
                  ENDIF                                                      INIPOSN.38    
 120           CONTINUE                                                      INIPOSN.39    
 110        CONTINUE                                                         INIPOSN.40    
            GOTO 990                                                         INIPOSN.41    
         ENDIF                                                               INIPOSN.42    
         IF (IPOSN(ICL).EQ.2) THEN                                           INIPOSN.43    
C                                                                            INIPOSN.44    
C     Initialise a particle on every other g.p. in the horizontal            INIPOSN.45    
C     and on levels given by ZCLUSTER.                                       INIPOSN.46    
C     ( NCL1=(MG+1)/2*(JG+1)/2*NCLUSTERS*NHEM ; integer division )           INIPOSN.47    
C                                                                            INIPOSN.48    
            DO 210 J=1,JG,2                                                  INIPOSN.49    
               DO 220 M=1,MG,2                                               INIPOSN.50    
                  ILAB=ILAB+1                                                INIPOSN.51    
                  POSN(NTIME,ILAB,1)=ZTBZX+M*DLAM                            INIPOSN.52    
                  POSN(NTIME,ILAB,2)=ALATT(J)                                INIPOSN.53    
                  IF(INISURF.GT.0) THEN                                      INIPOSN.54    
                     CALL ONTHETA(ILAB,ICL,M,J,NTIME)                        INIPOSN.55    
                  ELSE                                                       INIPOSN.56    
                     POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)                        INIPOSN.57    
                  ENDIF                                                      INIPOSN.58    
 220           CONTINUE                                                      INIPOSN.59    
 210        CONTINUE                                                         INIPOSN.60    
C                                                                            INIPOSN.61    
C     Set particles symmetrically about equator.                             INIPOSN.62    
C                                                                            INIPOSN.63    
            IF (NHEM.EQ.2) THEN                                              INIPOSN.64    
               DO 240 J=JGG,JG+1,-2                                          INIPOSN.65    
                  DO 250 M=1,MG,2                                            INIPOSN.66    
                     ILAB=ILAB+1                                             INIPOSN.67    
                     POSN(NTIME,ILAB,1)=ZTBZX+M*DLAM                         INIPOSN.68    
                     POSN(NTIME,ILAB,2)=ALATT(J)                             INIPOSN.69    
                     IF(INISURF.GT.0) THEN                                   INIPOSN.70    
                        CALL ONTHETA(ILAB,ICL,M,J,NTIME)                     INIPOSN.71    
                     ELSE                                                    INIPOSN.72    
                        POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)                     INIPOSN.73    
                     ENDIF                                                   INIPOSN.74    
 250              CONTINUE                                                   INIPOSN.75    
 240           CONTINUE                                                      INIPOSN.76    
            ENDIF                                                            INIPOSN.77    
            GOTO 990                                                         INIPOSN.78    
         ENDIF                                                               INIPOSN.79    
         IF (IPOSN(ICL).EQ.3) THEN                                           INIPOSN.80    
C                                                                            INIPOSN.81    
C     Rectangular clusters, each initialised on a single level.              INIPOSN.82    
C                                                                            INIPOSN.83    
C     Initialise a cluster with coordinates of north-west corner             INIPOSN.84    
C     given by XCLUSTER,YCLUSTER (in degrees) and ZCLUSTER (level).          INIPOSN.85    
C     The angular spacing between particles (in degrees) is given by         INIPOSN.86    
C     XSPACE and YSPACE, and the number of particles along                   INIPOSN.87    
C     a parallel and a meridian is given by NXACR and NYACR.                 INIPOSN.88    
C     All angles are converted to radians for the calculation.               INIPOSN.89    
C                                                                            INIPOSN.90    
C     Loop over the number of clusters.                                      INIPOSN.91    
C                                                                            INIPOSN.92    
            IF (XCLUSTER(ICL).LT.0.) THEN                                    INIPOSN.93    
               XCLUSTER(ICL)=360.+XCLUSTER(ICL)                              INIPOSN.94    
            ENDIF                                                            INIPOSN.95    
            XCL=XCLUSTER(ICL)*PI/180.                                        INIPOSN.96    
            YCL=YCLUSTER(ICL)*PI/180.                                        INIPOSN.97    
            XSP=XSPACE(ICL)*PI/180.                                          INIPOSN.98    
            YSP=YSPACE(ICL)*PI/180.                                          INIPOSN.99    
C                                                                            INIPOSN.100   
C     The origin of cluster is at the north-west corner.                     INIPOSN.101   
C     Position points on a grid to the right with correct spacing.           INIPOSN.102   
C                                                                            INIPOSN.103   
            DO 310 ID=1,NYACR(ICL)                                           INIPOSN.104   
               DO 320 I=1,NXACR(ICL)                                         INIPOSN.105   
                  ILAB=ILAB+1                                                INIPOSN.106   
                  POSN(NTIME,ILAB,1)=XCL+(I-1)*XSP                           INIPOSN.107   
                  POSN(NTIME,ILAB,2)=YCL-(ID-1)*YSP                          INIPOSN.108   
                  IF(INISURF.GT.0) THEN                                      INIPOSN.109   
                     CALL ONTHETA(ILAB,ICL,M,J,NTIME)                        INIPOSN.110   
                  ELSE                                                       INIPOSN.111   
                     POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)                        INIPOSN.112   
                  ENDIF                                                      INIPOSN.113   
 320           CONTINUE                                                      INIPOSN.114   
 310        CONTINUE                                                         INIPOSN.115   
            GOTO 990                                                         INIPOSN.116   
         ENDIF                                                               INIPOSN.117   
         IF (IPOSN(ICL).EQ.4) THEN                                           INIPOSN.118   
C                                                                            INIPOSN.119   
C     Rectangular clusters, each initialised on a single level.              INIPOSN.120   
C                                                                            INIPOSN.121   
C     As for IPOSN(ICL)=3 except spacing is regular in sin(latitude)         INIPOSN.122   
C     and units for Y... are expected to lie between -1 and 1.               INIPOSN.123   
C                                                                            INIPOSN.124   
C     Loop over the number of clusters.                                      INIPOSN.125   
C                                                                            INIPOSN.126   
            IF (XCLUSTER(ICL).LT.0.) THEN                                    INIPOSN.127   
               XCLUSTER(ICL)=360.+XCLUSTER(ICL)                              INIPOSN.128   
            ENDIF                                                            INIPOSN.129   
            XCL=XCLUSTER(ICL)*PI/180.                                        INIPOSN.130   
            YCL=YCLUSTER(ICL)                                                INIPOSN.131   
            XSP=XSPACE(ICL)*PI/180.                                          INIPOSN.132   
            YSP=YSPACE(ICL)                                                  INIPOSN.133   
C                                                                            INIPOSN.134   
C     The origin of cluster is at the north-west corner.                     INIPOSN.135   
C     Position points on a grid to the right with correct spacing.           INIPOSN.136   
C                                                                            INIPOSN.137   
            DO 410 ID=1,NYACR(ICL)                                           INIPOSN.138   
               YTEMP=YCL-(ID-1)*YSP                                          INIPOSN.139   
               IF (ABS(YTEMP).GT.1.) THEN                                    INIPOSN.140   
                  WRITE(LOUTP,*)                                             INIPOSN.141   
     :               '*****WARNING sin(lat) is out of range = ',YTEMP        INIPOSN.142   
                  STOP                                                       INIPOSN.143   
               ENDIF                                                         INIPOSN.144   
               YTEMP=ASIN(YTEMP)                                             INIPOSN.145   
               DO 420 I=1,NXACR(ICL)                                         INIPOSN.146   
                  ILAB=ILAB+1                                                INIPOSN.147   
                  POSN(NTIME,ILAB,1)=XCL+(I-1)*XSP                           INIPOSN.148   
                  POSN(NTIME,ILAB,2)=YTEMP                                   INIPOSN.149   
                  IF(INISURF.GT.0) THEN                                      INIPOSN.150   
                     CALL ONTHETA(ILAB,ICL,M,J,NTIME)                        INIPOSN.151   
                  ELSE                                                       INIPOSN.152   
                     POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)                        INIPOSN.153   
                  ENDIF                                                      INIPOSN.154   
 420           CONTINUE                                                      INIPOSN.155   
 410        CONTINUE                                                         INIPOSN.156   
            GOTO 990                                                         INIPOSN.157   
         ENDIF                                                               INIPOSN.158   
         IF (IPOSN(ICL).EQ.5) THEN                                           INIPOSN.159   
C                                                                            INIPOSN.160   
C     Ball clusters each containing 7 particles.                             INIPOSN.161   
C                                                                            INIPOSN.162   
C     Initialise a cluster with coordinates of centre given by               INIPOSN.163   
C     XCLUSTER,YCLUSTER (in degrees) and ZCLUSTER (level).                   INIPOSN.164   
C     The separation of particles in each cluster (in degrees)               INIPOSN.165   
C     is given by XSPACE and YSPACE.                                         INIPOSN.166   
C     All angles are converted to radians for the calculation.               INIPOSN.167   
C                                                                            INIPOSN.168   
C     Loop over the number of clusters.                                      INIPOSN.169   
C                                                                            INIPOSN.170   
            IF (XCLUSTER(ICL).LT.0.) THEN                                    INIPOSN.171   
               XCLUSTER(ICL)=360.+XCLUSTER(ICL)                              INIPOSN.172   
            ENDIF                                                            INIPOSN.173   
            XCL=XCLUSTER(ICL)*PI/180.                                        INIPOSN.174   
            YCL=YCLUSTER(ICL)*PI/180.                                        INIPOSN.175   
            XSP=XSPACE(ICL)*PI/180.                                          INIPOSN.176   
            YSP=YSPACE(ICL)*PI/180.                                          INIPOSN.177   
C                                                                            INIPOSN.178   
C     Intialise each ball of points around the central particle.             INIPOSN.179   
C                                                                            INIPOSN.180   
            DO 510 IBALL=1,7                                                 INIPOSN.181   
               ILAB=ILAB+1                                                   INIPOSN.182   
               XOFF=0.                                                       INIPOSN.183   
               PHIOFF=0.                                                     INIPOSN.184   
               SIGOFF=0.                                                     INIPOSN.185   
               IF(IBALL.EQ.2) XOFF=-XSP                                      INIPOSN.186   
               IF(IBALL.EQ.3) XOFF=XSP                                       INIPOSN.187   
               IF(IBALL.EQ.4) PHIOFF=-YSP                                    INIPOSN.188   
               IF(IBALL.EQ.5) PHIOFF=YSP                                     INIPOSN.189   
               IF(IBALL.EQ.6) SIGOFF=-ZSPACE(ICL)                            INIPOSN.190   
               IF(IBALL.EQ.7) SIGOFF=ZSPACE(ICL)                             INIPOSN.191   
               POSN(NTIME,ILAB,1)=XCL+XOFF                                   INIPOSN.192   
               POSN(NTIME,ILAB,2)=YCL+PHIOFF                                 INIPOSN.193   
               POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)+SIGOFF                       INIPOSN.194   
 510        CONTINUE                                                         INIPOSN.195   
            GOTO 990                                                         INIPOSN.196   
         ENDIF                                                               INIPOSN.197   
         IF (IPOSN(ICL).EQ.6) THEN                                           INIPOSN.198   
C                                                                            INIPOSN.199   
C     Initialise the particles in an isotropic, homogeneous pattern          INIPOSN.200   
C     on a polar stereographic projection with MOCT-fold symmetry.           INIPOSN.201   
C                                                                            INIPOSN.202   
C     PHILIM = the Southern extent of the particles (in degrees).            INIPOSN.203   
C     NPSET must be a multiple of the number of clusters.                    INIPOSN.204   
C                                                                            INIPOSN.205   
            ISTART=ILAB                                                      INIPOSN.206   
            NCL1=NPSET/NCLUSTERS                                             INIPOSN.207   
            N=INT(SQRT(REAL(MOCT*NCL1)/PI))+1                                INIPOSN.208   
            PHIL=PHILIM*PI/180.                                              INIPOSN.209   
            XLIM=COS(PHIL)/(1+SIN(PHIL))                                     INIPOSN.210   
            DX=XLIM/REAL(N)                                                  INIPOSN.211   
C                                                                            INIPOSN.212   
C     Loop over the nodes along the x-axis of the projection.                INIPOSN.213   
C                                                                            INIPOSN.214   
            X=-DX/2.                                                         INIPOSN.215   
            DO 610 I=1,N                                                     INIPOSN.216   
               X=X+DX                                                        INIPOSN.217   
               Y=DX/2.                                                       INIPOSN.218   
 620           RLAM=ATAN(Y/X)                                                INIPOSN.219   
               PHI=PI/2.-2*ATAN(SQRT(X**2+Y**2))                             INIPOSN.220   
C                                                                            INIPOSN.221   
C     Check to see if the (RLAM,PHI) point lies within the domain.           INIPOSN.222   
C     If it does the initialise its position and then increase y and         INIPOSN.223   
C     check the next point.                                                  INIPOSN.224   
C     Otherwise turn the particle OFF by setting its sigma-coordinate        INIPOSN.225   
C     to zero and then move on to the next node on the x-axis.               INIPOSN.226   
C                                                                            INIPOSN.227   
               IF ((RLAM.GT.0).AND.(RLAM.LT.PI2DM)                           INIPOSN.228   
     :              .AND.(PHI.GT.PHIL)) THEN                                 INIPOSN.229   
                  ILAB=ILAB+1                                                INIPOSN.230   
                  NDONE=ILAB-ISTART                                          INIPOSN.231   
                  IF (NDONE.GT.NCL1) GOTO 990                                INIPOSN.232   
                  POSN(NTIME,ILAB,1)=RLAM                                    INIPOSN.233   
                  POSN(NTIME,ILAB,2)=PHI                                     INIPOSN.234   
                  IF(INISURF.GT.0) THEN                                      INIPOSN.235   
                     CALL ONTHETA(ILAB,ICL,M,J,NTIME)                        INIPOSN.236   
                  ELSE                                                       INIPOSN.237   
                     POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)                        INIPOSN.238   
                  ENDIF                                                      INIPOSN.239   
                  Y=Y+DX                                                     INIPOSN.240   
                  GOTO 620                                                   INIPOSN.241   
               ENDIF                                                         INIPOSN.242   
 610        CONTINUE                                                         INIPOSN.243   
            GOTO 990                                                         INIPOSN.244   
         ENDIF                                                               INIPOSN.245   
         IF (IPOSN(ICL).EQ.7) THEN                                           INIPOSN.246   
C                                                                            INIPOSN.247   
C     Initialise positions from an existing '.bin' format traj file.         INIPOSN.248   
C     Convert degrees to radians for positions.                              INIPOSN.249   
C     The input file must be from a run which used LPOUT=.FALSE. .           INIPOSN.250   
C                                                                            INIPOSN.251   
            READ(NCINTRAJ,'(5I8)') NPARTR,NCLR,IPTSR,NATTRR,KFORWR           INIPOSN.252   
            READ(NCINTRAJ,'(2E13.5)') BEGDAYR,THISTR                         INIPOSN.253   
            READ(NCINTRAJ,'(5E13.5)') POSNB                                  INIPOSN.254   
            NSTART=NINT((BEGDAY-BEGDAYR)/THISTR) +1                          INIPOSN.255   
            DO 700 I=1,NPSET                                                 INIPOSN.256   
               ILAB=ILAB+1                                                   INIPOSN.257   
               POSN(NTIME,ILAB,1)=POSNB(NSTART,ILAB,1)*PI/180.               INIPOSN.258   
               POSN(NTIME,ILAB,2)=POSNB(NSTART,ILAB,2)*PI/180.               INIPOSN.259   
               POSN(NTIME,ILAB,3)=POSNB(NSTART,ILAB,3)/1000.                 INIPOSN.260   
 700        CONTINUE                                                         INIPOSN.261   
            GOTO 990                                                         INIPOSN.262   
         ENDIF                                                               INIPOSN.263   
         IF (IPOSN(ICL).EQ.9) THEN                                           ZATTR.17    
C                                                                            ZATTR.18    
C     Column of particles from the same site.                                ZATTR.19    
C                                                                            ZATTR.20    
C     Initialise a cluster with coordinates                                  ZATTR.21    
C     given by XCLUSTER,YCLUSTER (in degrees).                               ZATTR.22    
C     All angles are converted to radians for the calculation.               ZATTR.23    
C     Release levels match the levels for the wind data.                     ZATTR.24    
C                                                                            ZATTR.25    
            IF (XCLUSTER(ICL).LT.0.) THEN                                    ZATTR.26    
               XCLUSTER(ICL)=360.+XCLUSTER(ICL)                              ZATTR.27    
            ENDIF                                                            ZATTR.28    
            XCL=XCLUSTER(ICL)*PI/180.                                        ZATTR.29    
            YCL=YCLUSTER(ICL)*PI/180.                                        ZATTR.30    
            NCL1=NPSET/NCLUSTERS                                             ZATTR.31    
            DO 910 I=1,NCL1                                                  ZATTR.32    
               ILAB=ILAB+1                                                   ZATTR.33    
               POSN(NTIME,ILAB,1)=XCL                                        ZATTR.34    
               POSN(NTIME,ILAB,2)=YCL                                        ZATTR.35    
               POSN(NTIME,ILAB,3)=ALEV(NL+1-I)                               ZATTR.36    
 910        CONTINUE                                                         ZATTR.37    
            GOTO 990                                                         ZATTR.38    
         ENDIF                                                               ZATTR.39    
         WRITE(LOUTP,*) 'Position type ',IPOSN(ICL),                         INIPOSN.264   
     :        ' is not supported.'                                           INIPOSN.265   
C                                                                            INIPOSN.266   
 990     CONTINUE                                                            INIPOSN.267   
 10   CONTINUE                                                               INIPOSN.268   
C                                                                            INIPOSN.269   
      RETURN                                                                 INIPOSN.270   
      END                                                                    INIPOSN.271   
C     *************************************************************          INIPOSN.272   
      SUBROUTINE ONTHETA(ILAB,ICL,MR,JR,NTIME)                               ONTHETA.2     
C                                                                            ONTHETA.3     
C     To calculate the sigma-coordinate of a particle, label ILAB,           ONTHETA.4     
C     given its longitude, latitude and desired initial                      ONTHETA.5     
C     pressure or potential temperature of its cluster.                      ONTHETA.6     
C                                                                            ONTHETA.7     
C     INISURF=1 : Place on pressure surface (ZCLUSTER units: 10^5 Pa).       ONTHETA.8     
C     INISURF=2 : Place on theta surface (ZCLUSTER units: K).                ONTHETA.9     
C                                                                            ONTHETA.10    
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)                                       COMPSG.2     
C      PARAMETER(IGDLAP=1,IGCP=IGC)                                          COMPSG.3     
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)             COMPSG.4     
     :,BLETAM(IGCP,JG)                                                       SFCDATA.14    
C                                                                            COMPSG.5     
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/CLUSTERS/NCLUSTERS,IPOSN(MAXCLUS)                               CLUSTERS.2     
     :,IPOINTER(MAXCLUS)                                                     BUGS3EC.3     
     :,XCLUSTER(MAXCLUS),YCLUSTER(MAXCLUS),ZCLUSTER(MAXCLUS)                 CLUSTERS.3     
     :,XSPACE(MAXCLUS),YSPACE(MAXCLUS),ZSPACE(MAXCLUS)                       CLUSTERS.4     
     :,NXACR(MAXCLUS),NYACR(MAXCLUS),PHILIM,INISURF                          CLUSTERS.5     
C                                                                            CLUSTERS.6     
      PARAMETER (MAXIT=100)                                                  ONTHETA.19    
      REAL Y(3),THETA(NL),ZPART(NL),PHOUT(NL+1),PSURF,BOUND                  ONTHETA.20    
      REAL P,Q,OMP,OMQ,XA(4),YA(4),SIGOUT,THACC                              ONTHETA.21    
      INTEGER ILAB,ICL,MR,JR,M,MP,J,JM,JHEM,JHEMM,L                          ONTHETA.22    
C                                                                            ONTHETA.23    
C     If particles do not intially lie on g.p.'s in the horizontal           ONTHETA.24    
C     then interpolate the theta field to the particle's horizontal          ONTHETA.25    
C     position.                                                              ONTHETA.26    
C                                                                            ONTHETA.27    
      IF (IPOSN(ICL).GE.3) THEN                                              ONTHETA.28    
C                                                                            ONTHETA.29    
C     Find the south-west vertex of the grid box surrounding                 ONTHETA.30    
C     the particle.                                                          ONTHETA.31    
C                                                                            ONTHETA.32    
                                                                             ONTHETA.33    
         Y(1)=POSN(NTIME,ILAB,1)                                             ONTHETA.34    
         Y(2)=POSN(NTIME,ILAB,2)                                             ONTHETA.35    
         Y(3)=0.                                                             ONTHETA.36    
         CALL FINDSW(Y,ZTBZX,DLAM,ALATT                                      ONTHETA.37    
     :        ,M,MP,J,JM,P,Q,JHEM,JHEMM)                                     ONTHETA.38    
         OMP=1.-P                                                            ONTHETA.39    
         OMQ=1.-Q                                                            ONTHETA.40    
C                                                                            ONTHETA.41    
C     Horizontal linear interpolation of theta for all NL points             ONTHETA.42    
C     in the vertical.                                                       ONTHETA.43    
C                                                                            ONTHETA.44    
         F1=PLGLA(M+(JHEM-1)*MGPP,J)                                         ONTHETA.45    
         F2=PLGLA(MP+(JHEM-1)*MGPP,J)                                        ONTHETA.46    
         F3=PLGLA(MP+(JHEMM-1)*MGPP,JM)                                      ONTHETA.47    
         F4=PLGLA(M+(JHEMM-1)*MGPP,JM)                                       ONTHETA.48    
         PSURF=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                           ONTHETA.49    
         IF (INISURF.EQ.1) THEN                                              ONTHETA.50    
            IF (ZCLUSTER(ICL).GE.PSURF) THEN                                 BUGS3EC.11    
               POSN(NTIME,ILAB,3)=0.999                                      BUGS3EC.12    
               RETURN                                                        BUGS3EC.13    
            ENDIF                                                            BUGS3EC.14    
            THACC=1.E-6                                                      ONTHETA.51    
            DO 10 LH=1,NL+1                                                  ONTHETA.52    
               PHOUT(LH)=AETA(LH)+BETA(LH)*PSURF                             ONTHETA.53    
 10         CONTINUE                                                         ONTHETA.54    
            DO 12 L=1,NL                                                     ONTHETA.55    
               THETA(L)=.5*(PHOUT(L)+PHOUT(L+1))                             ONTHETA.56    
 12         CONTINUE                                                         ONTHETA.57    
         ENDIF                                                               ONTHETA.58    
         IF (INISURF.EQ.2) THEN                                              ONTHETA.59    
            THACC=1.E-4                                                      ONTHETA.60    
            CALL FINDALEV(THGLA,THETA,M,MP,J,JM,P,Q,JHEM,JHEMM)              ONTHETA.61    
            IF (LOROG) THEN                                                  ONTHETA.62    
               CALL FINDALEV(PSGLA,ZPART,M,MP,J,JM,P,Q,JHEM,JHEMM)           ONTHETA.63    
            ENDIF                                                            ONTHETA.64    
         ENDIF                                                               ONTHETA.65    
      ELSE                                                                   ONTHETA.66    
C                                                                            ONTHETA.67    
C     Find theta on each level at the particle's starting g.p.               ONTHETA.68    
C     for IPOSN(ICL)=1 or 2.                                                 ONTHETA.69    
C                                                                            ONTHETA.70    
C     Set up as if for hemispheric mode and make appropriate changes         ONTHETA.71    
C     if particles lie in the Southern hemisphere.                           ONTHETA.72    
C                                                                            ONTHETA.73    
         JHEM=1                                                              ONTHETA.74    
         J=JR                                                                ONTHETA.75    
         M=MR                                                                ONTHETA.76    
         IF (J.GT.JG) THEN                                                   ONTHETA.77    
            JHEM=2                                                           ONTHETA.78    
            J=JGGP-JR                                                        ONTHETA.79    
         ENDIF                                                               ONTHETA.80    
         PSURF=PLGLA(M+(JHEM-1)*MGPP,J)                                      ONTHETA.81    
         IF (INISURF.EQ.1) THEN                                              ONTHETA.82    
            IF (ZCLUSTER(ICL).GE.PSURF) THEN                                 BUGS3EC.15    
               POSN(NTIME,ILAB,3)=0.999                                      BUGS3EC.16    
               RETURN                                                        BUGS3EC.17    
            ENDIF                                                            BUGS3EC.18    
            THACC=1.E-6                                                      ONTHETA.83    
            DO 30 LH=1,NL+1                                                  ONTHETA.84    
               PHOUT(LH)=AETA(LH)+BETA(LH)*PSURF                             ONTHETA.85    
 30         CONTINUE                                                         ONTHETA.86    
            DO 32 L=1,NL                                                     ONTHETA.87    
               THETA(L)=.5*(PHOUT(L)+PHOUT(L+1))                             ONTHETA.88    
 32         CONTINUE                                                         ONTHETA.89    
         ENDIF                                                               ONTHETA.90    
         IF (INISURF.EQ.2) THEN                                              ONTHETA.91    
            THACC=1.E-4                                                      ONTHETA.92    
            DO 44 L=1,NL                                                     ONTHETA.93    
               THETA(L)=THGLA(M+(JHEM-1)*MGPP+(L-1)*IGC+(J-1)*IGD)           ONTHETA.94    
 44         CONTINUE                                                         ONTHETA.95    
            IF (LOROG) THEN                                                  ONTHETA.96    
               DO 46 L=1,NL                                                  ONTHETA.97    
                  ZPART(L)=PSGLA(M+(JHEM-1)*MGPP+(L-1)*IGC+(J-1)*IGD)        ONTHETA.98    
 46            CONTINUE                                                      ONTHETA.99    
            ENDIF                                                            ONTHETA.100   
         ENDIF                                                               ONTHETA.101   
      ENDIF                                                                  ONTHETA.102   
C                                                                            ONTHETA.103   
C     Theta (or pressure) on each level at the particle's horizontal         ONTHETA.104   
C     position has now been found. Search the theta array to find L          ONTHETA.105   
C     such that:-                                                            ONTHETA.106   
C        THETA(L) > ZCLUSTER(ICL) > THETA(L+1)                               ONTHETA.107   
C                                                                            ONTHETA.108   
C     NOTE : Theta decreases with increasing L.                              ONTHETA.109   
C                                                                            ONTHETA.110   
      IF ((INISURF.EQ.2).AND.(ZCLUSTER(ICL).LT.THETA(NL))) THEN              BUGS3EC.69    
c         WRITE(LOUTP,*) 'Initial posn below ground for particle ',ILAB      BUGS3EC.70    
c	  WRITE(LOUTP,*) THETA(NL)                                                 BUGS3EC.71    
         SIGOUT=-1.                                                          BUGS3EC.72    
         GOTO 70                                                             BUGS3EC.73    
      ENDIF                                                                  BUGS3EC.74    
      L=NL/2                                                                 ONTHETA.111   
      CALL HUNT(THETA,NL,ZCLUSTER(ICL),L)                                    ONTHETA.112   
C                                                                            ONTHETA.113   
C     Set up the points used for cubic interpolation in the region of        ONTHETA.114   
C     theta value ZCLUSTER(ICL).                                             ONTHETA.115   
C                                                                            ONTHETA.116   
      LSTART=2                                                               ONTHETA.117   
      IF (L.LT.2) THEN                                                       ONTHETA.118   
         L=2                                                                 ONTHETA.119   
         LSTART=1                                                            ONTHETA.120   
      ENDIF                                                                  ONTHETA.121   
      IF (L.GT.(NL-2)) THEN                                                  ONTHETA.122   
         L=NL-2                                                              ONTHETA.123   
         LSTART=3                                                            ONTHETA.124   
      ENDIF                                                                  ONTHETA.125   
      DO 50 IPT=1,4                                                          ONTHETA.126   
         LPT=L+IPT-2                                                         ONTHETA.127   
         XA(IPT)=ALEV(LPT)                                                   ONTHETA.128   
         YA(IPT)=THETA(LPT)-ZCLUSTER(ICL)                                    ONTHETA.129   
 50   CONTINUE                                                               ONTHETA.130   
C                                                                            ONTHETA.131   
C     Use the SECANT method to find the root of (theta-ZCLUSTER) in          ONTHETA.132   
C     the region close to the bracketting levels (or inner 2 levels          ONTHETA.133   
C     which do not bracket the particle near the boundaries).                ONTHETA.134   
C                                                                            ONTHETA.135   
C                       Numerical Recipes p.250                              ONTHETA.136   
C     The desired accuracy of (theta-ZCLUSTER) is given by THACC.            ONTHETA.137   
C                                                                            ONTHETA.138   
      FL=YA(LSTART)                                                          ONTHETA.139   
      F=YA(LSTART+1)                                                         ONTHETA.140   
      IF (ABS(F-FL).LT.THACC) THEN                                           BUGS3EC.75    
         F=F-THACC                                                           BUGS3EC.76    
      ENDIF                                                                  BUGS3EC.77    
      IF (ABS(FL).LT.ABS(F)) THEN                                            ONTHETA.141   
         SIGOUT=XA(LSTART)                                                   ONTHETA.142   
         XL=XA(LSTART+1)                                                     ONTHETA.143   
         SWAP=FL                                                             ONTHETA.144   
         FL=F                                                                ONTHETA.145   
         F=SWAP                                                              ONTHETA.146   
      ELSE                                                                   ONTHETA.147   
         XL=XA(LSTART)                                                       ONTHETA.148   
         SIGOUT=XA(LSTART+1)                                                 ONTHETA.149   
      ENDIF                                                                  ONTHETA.150   
C                                                                            ONTHETA.151   
C     Secant loop.                                                           ONTHETA.152   
C                                                                            ONTHETA.153   
      DO 60 I=1,MAXIT                                                        ONTHETA.154   
         DX=(XL-SIGOUT)*F/(F-FL)                                             ONTHETA.155   
         XL=SIGOUT                                                           ONTHETA.156   
         FL=F                                                                ONTHETA.157   
         SIGOUT=SIGOUT+DX                                                    ONTHETA.158   
         CALL POLINT(XA,YA,4,SIGOUT,F,DF)                                    ONTHETA.159   
         IF (ABS(F).LT.THACC) GOTO 70                                        ONTHETA.160   
 60   CONTINUE                                                               ONTHETA.161   
      WRITE(LOUTP,*) 'Initial surface not located for particle ',ILAB        ONTHETA.162   
      WRITE(LOUTP,'(5E13.5)') THETA                                          ONTHETA.163   
 70   CONTINUE                                                               ONTHETA.164   
                                                                             ONTHETA.165   
C     If the particle lies outside the range of the model levels             ONTHETA.166   
C     then turn the particle OFF by setting its eta-coord to zero.           ONTHETA.167   
C                                                                            ONTHETA.168   
      IF (SIGOUT.LT.0.) THEN                                                 ONTHETA.169   
         POSN(NTIME,ILAB,3)=0.                                               ONTHETA.170   
      ELSE                                                                   ONTHETA.171   
         BOUND=1.                                                            ONTHETA.172   
         IF (ILEVTYPE.GE.1) BOUND=PSURF                                      ONTHETA.173   
         IF (LOROG) THEN                                                     ONTHETA.174   
C                                                                            ONTHETA.175   
C     Height of each level at the particle's horizontal                      ONTHETA.176   
C     position has now been found. Search the ZPART array to find L          ONTHETA.177   
C     such that:-                                                            ONTHETA.178   
C        ZPART(L) < PSURF < ZPART(L+1)                                       ONTHETA.179   
C                                                                            ONTHETA.180   
C     NOTE : ZPART increases with increasing L and PSURF contains            ONTHETA.181   
C     orographic height.                                                     ONTHETA.182   
C                                                                            ONTHETA.183   
            L=2                                                              ONTHETA.184   
            CALL HUNT(ZPART,NL,PSURF,L)                                      ONTHETA.185   
            IF (L.LE.1) L=1                                                  ONTHETA.186   
            BOUND=ALEV(L)+(PSURF-ZPART(L))                                   ONTHETA.187   
     :           *(ALEV(L+1)-ALEV(L))/(ZPART(L+1)-ZPART(L))                  ONTHETA.188   
         ENDIF                                                               ONTHETA.189   
         IF (SIGOUT.GT.BOUND) THEN                                           ONTHETA.190   
            POSN(NTIME,ILAB,3)=0.999*BOUND                                   ONTHETA.191   
         ELSE                                                                ONTHETA.192   
            POSN(NTIME,ILAB,3)=SIGOUT                                        ONTHETA.193   
         ENDIF                                                               ONTHETA.194   
      ENDIF                                                                  ONTHETA.195   
C                                                                            ONTHETA.196   
      RETURN                                                                 ONTHETA.197   
      END                                                                    ONTHETA.198   
C     ***************************************************************        ONTHETA.199   
      SUBROUTINE READGP                                                      READGP.2     
C                                                                            READGP.3     
C     Read GRID POINT wind records for use in trajectory code.               READGP.4     
C                                                                            READGP.5     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)                                       COMPSG.2     
C      PARAMETER(IGDLAP=1,IGCP=IGC)                                          COMPSG.3     
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)             COMPSG.4     
     :,BLETAM(IGCP,JG)                                                       SFCDATA.14    
C                                                                            COMPSG.5     
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
C                                                                            READGP.13    
C     NOTES:                                                                 READGP.14    
C                                                                            READGP.15    
C     Should have already specified grid spacing in                          READGP.16    
C     latitude (ALAT) and vertical coordinate (ALEV).                        READGP.17    
C     Assume that grid is regular in longitude.                              READGP.18    
C                                                                            READGP.19    
      DO 5 ICHAN=1,MAXATTR                                                   BUGS3EC.51    
         REWIND(NCGP(ICHAN))                                                 BUGS3EC.52    
    5 CONTINUE                                                               BUGS3EC.53    
      IF (ILEVTYPE.LT.2) THEN                                                READGP.20    
C                                                                            READGP.21    
C     Data is given on model levels which are labelled by a                  READGP.22    
C     known pressure-based coordinate (i.e. eta or pressure).                READGP.23    
C                                                                            READGP.24    
         IF (IUVFORMAT.EQ.0) CALL READEC                                     READGP.25    
         IF (IUVFORMAT.EQ.2) CALL READUM                                     READGP.26    
         IF (IUVFORMAT.EQ.3) CALL READARB                                    READGP.27    
      ELSE                                                                   READGP.28    
C                                                                            READGP.29    
C     Read in wind fields.                                                   READGP.30    
C     Below is an example. If your data is formatted differently             READGP.31    
C     then read it and write it to the following arrays.                     READGP.32    
C                                                                            READGP.33    
C     URHS  : d(lon)/dt                                                      READGP.34    
C     VRHS  : d(lat)/dt                                                      READGP.35    
C     SDRHS : Omega (dp/dt)                                                  READGP.36    
C     PSGLA : Pressure (p) on grid points.                                   READGP.37    
C                                                                            READGP.38    
C     Each of these arrays should be ordered with an inner                   READGP.39    
C     loop over MGPP, a loop over NHEM, a loop over NL and                   READGP.40    
C     finally an outer loop over JG                                          READGP.41    
C     (total length IGDLA=MGPP*NHEM*NL*JG).                                  READGP.42    
C                                                                            READGP.43    
C     It is assumed during interpolation that all four of                    READGP.44    
C     these fields are given on the same grid.                               READGP.45    
C                                                                            READGP.46    
C     WARNINGS: Without surface pressure it is not possible                  READGP.47    
C     to detect whether particles leave the bottom of the domain.            READGP.48    
C     In addition, it is not possible to use the lower                       READGP.49    
C     boundary condition for vertical velocity.                              READGP.50    
C                                                                            READGP.51    
         READ(INPUT,*) URHS,VRHS,SDRHS,PSGLA                                 READGP.52    
      ENDIF                                                                  READGP.53    
C                                                                            READGP.54    
C     Change sign of the wind components for back trajectories.              READGP.55    
C                                                                            READGP.56    
      IF (.NOT.LFORW) THEN                                                   READGP.57    
         DO 10 I=1,IGDLA                                                     READGP.58    
            URHS(I)=-URHS(I)                                                 READGP.59    
            VRHS(I)=-VRHS(I)                                                 READGP.60    
            SDRHS(I)=-SDRHS(I)                                               READGP.61    
 10      CONTINUE                                                            READGP.62    
      ENDIF                                                                  READGP.63    
C                                                                            READGP.64    
      RETURN                                                                 READGP.65    
      END                                                                    READGP.66    
C     *************************************************************          READGP.67    
      SUBROUTINE RKDUMB(YSTART,N,T1,T2,NSTEPS,H)                             RKDUMB.2     
C                                                                            RKDUMB.3     
C     Runge-Kutta time steps with fixed step-size.                           RKDUMB.4     
C     Integrate the N-1 starting values YSTART, from T1 to T2.               RKDUMB.5     
C     H is the fixed step size and is determined from NSTEPS.                RKDUMB.6     
C     On output YSTART is replaced by values at the end of the               RKDUMB.7     
C     integration interval. DERIVS is the routine for calculating            RKDUMB.8     
C     the right hand side wind terms.                                        RKDUMB.9     
C                                                                            RKDUMB.10    
C     PATH=Storage for intermediate coords along trajectory.                 RKDUMB.11    
C                                                                            RKDUMB.12    
C     Derived from routines in Numerical Recipes (pp. 550-554).              RKDUMB.13    
C                                                                            RKDUMB.14    
C                                                                            PATH.2     
C     Must ensure that NSTSAV >= NSTEPS.                                     PATH.3     
C                                                                            PATH.4     
      PARAMETER(NSTSAV=120)                                                  JOBID.13    
      COMMON/PATH/YP(NSTSAV,3)                                               PATH.6     
C                                                                            PATH.7     
      PARAMETER(NMAX=4)                                                      RKDUMB.16    
      REAL YSTART(NMAX-1),Y(NMAX-1),DYDT(NMAX-1)                             RKDUMB.17    
      REAL YT(NMAX-1),DYT(NMAX-1),DYM(NMAX-1)                                RKDUMB.18    
      REAL C(NMAX),DCDT(NMAX),CT(NMAX),DCT(NMAX),DCM(NMAX)                   RKDUMB.19    
      REAL H,HH,H6,T,TH,BOUND                                                RKDUMB.20    
C                                                                            RKDUMB.21    
      HH=H*0.5                                                               RKDUMB.22    
      H6=H/6.                                                                RKDUMB.23    
      T=T1                                                                   RKDUMB.24    
C                                                                            RKDUMB.25    
      DO 10 I=1,N-1                                                          RKDUMB.26    
         Y(I)=YSTART(I)                                                      RKDUMB.27    
 10   CONTINUE                                                               RKDUMB.28    
C                                                                            RKDUMB.29    
C     Coordinate transformation.                                             RKDUMB.30    
C                                                                            RKDUMB.31    
      C(1)=COS(Y(2))*COS(Y(1))                                               RKDUMB.32    
      C(2)=COS(Y(2))*SIN(Y(1))                                               RKDUMB.33    
      C(3)=SIN(Y(2))                                                         RKDUMB.34    
      C(4)=Y(3)                                                              RKDUMB.35    
C                                                                            RKDUMB.36    
      DO 20 K=1,NSTEPS                                                       RKDUMB.37    
C                                                                            RKDUMB.38    
C     Given values for N-1 variables Y (lon,lat,p) and their                 RKDUMB.39    
C     derivatives DYDT, known at time T, use the fourth-order                RKDUMB.40    
C     Runge-Kutta method to advance the solution over an interval H.         RKDUMB.41    
C                                                                            RKDUMB.42    
C     The R-K integrator increments the position on the unit sphere          RKDUMB.43    
C     using 3-D Cartesian geometry to improve accuracy near the poles,       RKDUMB.44    
C     rather than using spherical polar coordinates (lon,lat).               RKDUMB.45    
C     Now a particle's position is given by FOUR coordinates                 RKDUMB.46    
C     (in array C): the position on the sphere (x,y,z) and the               RKDUMB.47    
C     altitude (in appropriate vertical coordinate).                         RKDUMB.48    
C                                                                            RKDUMB.49    
C     First step.                                                            RKDUMB.50    
C                                                                            RKDUMB.51    
         CALL DERIVS(T,T1,T2,Y,DYDT,BOUND)                                   RKDUMB.52    
         CALL YTOC(Y,DYDT,DCDT,N)                                            RKDUMB.53    
         DO 11 I=1,N                                                         RKDUMB.54    
            CT(I)=C(I)+HH*DCDT(I)                                            RKDUMB.55    
 11      CONTINUE                                                            RKDUMB.56    
         CALL CTOY(YT,CT,N,BOUND)                                            RKDUMB.57    
C                                                                            RKDUMB.58    
C     Second step.                                                           RKDUMB.59    
C                                                                            RKDUMB.60    
         TH=T+HH                                                             RKDUMB.61    
         CALL DERIVS(TH,T1,T2,YT,DYT,BOUND)                                  RKDUMB.62    
         CALL YTOC(YT,DYT,DCT,N)                                             RKDUMB.63    
         DO 12 I=1,N                                                         RKDUMB.64    
            CT(I)=C(I)+HH*DCT(I)                                             RKDUMB.65    
 12      CONTINUE                                                            RKDUMB.66    
         CALL CTOY(YT,CT,N,BOUND)                                            RKDUMB.67    
C                                                                            RKDUMB.68    
C     Third step.                                                            RKDUMB.69    
C                                                                            RKDUMB.70    
         CALL DERIVS(TH,T1,T2,YT,DYM,BOUND)                                  RKDUMB.71    
         CALL YTOC(YT,DYM,DCM,N)                                             RKDUMB.72    
         DO 13 I=1,N                                                         RKDUMB.73    
            CT(I)=C(I)+H*DCM(I)                                              RKDUMB.74    
            DCM(I)=DCT(I)+DCM(I)                                             RKDUMB.75    
 13      CONTINUE                                                            RKDUMB.76    
         CALL CTOY(YT,CT,N,BOUND)                                            RKDUMB.77    
C                                                                            RKDUMB.78    
C     Fourth step.                                                           RKDUMB.79    
C                                                                            RKDUMB.80    
         CALL DERIVS(T+H,T1,T2,YT,DYT,BOUND)                                 RKDUMB.81    
C                                                                            RKDUMB.82    
C     Accumulate increments with proper weights.                             RKDUMB.83    
C                                                                            RKDUMB.84    
         CALL YTOC(YT,DYT,DCT,N)                                             RKDUMB.85    
         DO 14 I=1,N                                                         RKDUMB.86    
            C(I)=C(I)+H6*(DCDT(I)+DCT(I)+2.*DCM(I))                          RKDUMB.87    
 14      CONTINUE                                                            RKDUMB.88    
         CALL CTOY(Y,C,N,BOUND)                                              RKDUMB.89    
         T=T+H                                                               RKDUMB.90    
C                                                                            RKDUMB.91    
C     Save intermediate trajectory coordinates.                              RKDUMB.92    
C                                                                            RKDUMB.93    
         DO 16 I=1,N-1                                                       RKDUMB.94    
            YP(K,I)=Y(I)                                                     RKDUMB.95    
 16      CONTINUE                                                            RKDUMB.96    
 20   CONTINUE                                                               RKDUMB.97    
C                                                                            RKDUMB.98    
C     Save final positions.                                                  RKDUMB.99    
C                                                                            RKDUMB.100   
      DO 30 I=1,N-1                                                          RKDUMB.101   
         YSTART(I)=Y(I)                                                      RKDUMB.102   
 30   CONTINUE                                                               RKDUMB.103   
C                                                                            RKDUMB.104   
      RETURN                                                                 RKDUMB.105   
      END                                                                    RKDUMB.106   
C     ****************************************************************       RKDUMB.107   
      SUBROUTINE YTOC(Y,DY,DC,N)                                             YTOC.2     
C                                                                            YTOC.3     
C     Convert (d(lon)/dt,d(lat)/dt,omega) to (u,v,w,omega).                  YTOC.4     
C     Omega is the vertical velocity in chosen vertical coordinates          YTOC.5     
C     (see IUVFORMAT) and u,v and w are velocity components of               YTOC.6     
C     wind on surface of the sphere in 3-D Cartesian geometry.               YTOC.7     
C     This coordinate system improves accuracy near the poles.               YTOC.8     
C                                                                            YTOC.9     
      REAL Y(N-1),DY(N-1),DC(N),CLON,CLAT,SLON,SLAT                          YTOC.10    
C                                                                            YTOC.11    
      CLON=COS(Y(1))                                                         YTOC.12    
      CLAT=COS(Y(2))                                                         YTOC.13    
      SLON=SIN(Y(1))                                                         YTOC.14    
      SLAT=SIN(Y(2))                                                         YTOC.15    
      DC(1)=-CLAT*SLON*DY(1)-SLAT*CLON*DY(2)                                 YTOC.16    
      DC(2)=CLAT*CLON*DY(1)-SLAT*SLON*DY(2)                                  YTOC.17    
      DC(3)=CLAT*DY(2)                                                       YTOC.18    
      DC(4)=DY(3)                                                            YTOC.19    
C                                                                            YTOC.20    
      RETURN                                                                 YTOC.21    
      END                                                                    YTOC.22    
C     ******************************************************************     YTOC.23    
      SUBROUTINE CTOY(Y,C,N,BOUND)                                           CTOY.2     
C                                                                            CTOY.3     
C     Convert (x,y,z,p) to (lon,lat,p).                                      CTOY.4     
C     p refers to the vertical coordinate (see IUVFORMAT).                   CTOY.5     
C                                                                            CTOY.6     
      PARAMETER(PI=3.14159265359)                                            CTOY.7     
      REAL Y(N-1),C(N),BOUND,F,C1,C2                                         CTOY.8     
C                                                                            CTOY.9     
C     Adjust 3-D Cartesian position back to sphere                           CTOY.10    
C     so that x**2+y**2+z**2=1.                                              CTOY.11    
C                                                                            CTOY.12    
      F=1./SQRT(C(1)*C(1)+C(2)*C(2)+C(3)*C(3))                               CTOY.13    
      DO 10 I=1,3                                                            CTOY.14    
         C(I)=F*C(I)                                                         CTOY.15    
 10   CONTINUE                                                               CTOY.16    
      IF (ABS(C(3)).LT.1.) THEN                                              BUGS3EC.21    
         Y(2)=ASIN(C(3))                                                     BUGS3EC.22    
         C1=C(1)/COS(Y(2))                                                   BUGS3EC.23    
         C2=C(2)/COS(Y(2))                                                   BUGS3EC.24    
         IF (ABS(C1).LT.1.) THEN                                             BUGS3EC.25    
            Y(1)=ACOS(C1)                                                    BUGS3EC.26    
            IF (C2.LT.0.) Y(1)=2.*PI-Y(1)                                    BUGS3EC.27    
         ELSE                                                                BUGS3EC.28    
            WRITE(*,*) ' cos(lon) = ',C1                                     BUGS3EC.29    
            IF (C1.GE.1.) THEN                                               BUGS3EC.30    
               Y(1)=0.                                                       BUGS3EC.31    
            ELSE                                                             BUGS3EC.32    
               Y(1)=PI                                                       BUGS3EC.33    
            ENDIF                                                            BUGS3EC.34    
         ENDIF                                                               BUGS3EC.35    
      ELSE                                                                   BUGS3EC.36    
         WRITE(*,*) ' Z = ',C(3)                                             BUGS3EC.37    
         Y(2)=(PI/2.00001)*NINT(C(3))                                        BUGS3EC.38    
      ENDIF                                                                  BUGS3EC.39    
C                                                                            CTOY.23    
C     Ensure that particle lies within domain.                               CTOY.24    
C                                                                            CTOY.25    
      Y(3)=C(4)                                                              CTOY.26    
      IF (Y(3).LT.0.) Y(3)=0.                                                CTOY.27    
      IF (Y(3).GE.BOUND) Y(3)=0.999*BOUND                                    CTOY.28    
C                                                                            CTOY.29    
      RETURN                                                                 CTOY.30    
      END                                                                    CTOY.31    
C     ******************************************************************     CTOY.32    
      SUBROUTINE DERIVS(T,T1,T2,Y,DYDT,BOUND)                                DERIVS.2     
C                                                                            DERIVS.3     
C     Returns derivatives DYDT at T. DYDT are found from looking up          DERIVS.4     
C     the wind fields from grid point versions of model output.              DERIVS.5     
C     BOUND refers to the vertical coordinate of the lower boundary.         DERIVS.6     
C                                                                            DERIVS.7     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)                                       COMPSG.2     
C      PARAMETER(IGDLAP=1,IGCP=IGC)                                          COMPSG.3     
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)             COMPSG.4     
     :,BLETAM(IGCP,JG)                                                       SFCDATA.14    
C                                                                            COMPSG.5     
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      REAL T,T1,T2,Y(3),DYDT(3),DYDTM(3)                                     DERIVS.14    
     :     ,P,Q,PT,QT,S,OMS,PP(NL),PM(NL)                                    DERIVS.15    
     :     ,BOUND,BOUNDP,BOUNDM,DPSDT,ZEDGE,WEDGE                            DERIVS.16    
      INTEGER M,J,L,LH,MP,JM,JHEM,JHEMM,IEDGE                                DERIVS.17    
     :       ,MT,JT,MPT,JMT,JHEMT,JHEMMT                                     DERIVS.18    
C                                                                            DERIVS.19    
C     Time interpolation weights.                                            DERIVS.20    
C                                                                            DERIVS.21    
      S=(T-T1)/(T2-T1)                                                       DERIVS.22    
      OMS=1.-S                                                               DERIVS.23    
C                                                                            DERIVS.24    
C     Find the south-west vertex of the grid box surrounding                 DERIVS.25    
C     the particle.                                                          DERIVS.26    
C                                                                            DERIVS.27    
      CALL FINDSW(Y,ZUBZX,DLAM,ALAT                                          DERIVS.28    
     :        ,M,MP,J,JM,P,Q,JHEM,JHEMM)                                     DERIVS.29    
      MT=M                                                                   DERIVS.30    
      MPT=MP                                                                 DERIVS.31    
      JT=J                                                                   DERIVS.32    
      JMT=JM                                                                 DERIVS.33    
      PT=P                                                                   DERIVS.34    
      QT=Q                                                                   DERIVS.35    
      JHEMT=JHEM                                                             DERIVS.36    
      JHEMMT=JHEMM                                                           DERIVS.37    
      IF (IUVFORMAT.EQ.2) THEN                                               DERIVS.38    
         CALL FINDSW(Y,ZTBZX,DLAM,ALATT                                      DERIVS.39    
     :        ,MT,MPT,JT,JMT,PT,QT,JHEMT,JHEMMT)                             DERIVS.40    
      ENDIF                                                                  DERIVS.41    
C                                                                            DERIVS.42    
C     Find pressure on model levels if particle positions                    DERIVS.43    
C     and velocities are defined in pressure coordinates.                    DERIVS.44    
C                                                                            DERIVS.45    
      IF (ILEVTYPE.EQ.0) THEN                                                DERIVS.46    
         BOUND=1.                                                            DERIVS.47    
         DPSDT=0.                                                            DERIVS.48    
      ELSE                                                                   DERIVS.49    
         IF (LOROG.OR.(ILEVTYPE.EQ.2)) THEN                                  DERIVS.50    
            CALL FINDALEV(PSGLA,PP,MT,MPT,JT,JMT,PT,QT,JHEMT,JHEMMT)         DERIVS.51    
            CALL FINDALEV(PSGLAM,PM,MT,MPT,JT,JMT,PT,QT,JHEMT,JHEMMT)        DERIVS.52    
            IF (ILEVTYPE.EQ.2) THEN                                          DERIVS.53    
               DO 10 L=1,NL                                                  DERIVS.54    
                  ALEV(L)=S*PP(L)+OMS*PM(L)                                  DERIVS.55    
 10            CONTINUE                                                      DERIVS.56    
            ENDIF                                                            DERIVS.57    
         ENDIF                                                               DERIVS.58    
         OMP=1.-PT                                                           DERIVS.59    
         OMQ=1.-QT                                                           DERIVS.60    
         F1=PLGLAM(MT+(JHEMT-1)*MGPP,JT)                                     DERIVS.61    
         F2=PLGLAM(MPT+(JHEMT-1)*MGPP,JT)                                    DERIVS.62    
         F3=PLGLAM(MPT+(JHEMMT-1)*MGPP,JMT)                                  DERIVS.63    
         F4=PLGLAM(MT+(JHEMMT-1)*MGPP,JMT)                                   DERIVS.64    
         PSM=QT*PT*F3+QT*OMP*F4+OMQ*PT*F2+OMQ*OMP*F1                         DERIVS.65    
         F1=PLGLA(MT+(JHEMT-1)*MGPP,JT)                                      DERIVS.66    
         F2=PLGLA(MPT+(JHEMT-1)*MGPP,JT)                                     DERIVS.67    
         F3=PLGLA(MPT+(JHEMMT-1)*MGPP,JMT)                                   DERIVS.68    
         F4=PLGLA(MT+(JHEMMT-1)*MGPP,JMT)                                    DERIVS.69    
         PSP=QT*PT*F3+QT*OMP*F4+OMQ*PT*F2+OMQ*OMP*F1                         DERIVS.70    
         IF (.NOT.LOROG) THEN                                                DERIVS.71    
            BOUND=S*PSP+OMS*PSM                                              DERIVS.72    
            DPSDT=(PSP-PSM)/(T2-T1)                                          DERIVS.73    
         ELSE                                                                DERIVS.74    
C                                                                            DERIVS.75    
C     Height of each level at the particle's horizontal                      DERIVS.76    
C     position has now been found, search the PP and PM arrays               DERIVS.77    
C     to find L such that:-                                                  DERIVS.78    
C        PP(L) < PSP < PP(L+1)                                               DERIVS.79    
C                                                                            DERIVS.80    
C     NOTE : PP increases with increasing L and PSP contains                 DERIVS.81    
C     orographic height.                                                     DERIVS.82    
C                                                                            DERIVS.83    
            L=2                                                              DERIVS.84    
            CALL HUNT(PP,NL,PSP,L)                                           DERIVS.85    
            IF (L.LE.1) L=1                                                  DERIVS.86    
            IF (L.GE.NL) L=NL-1                                              BUGS3EC.19    
            BOUNDP=ALEV(L)+(PSP-PP(L))                                       DERIVS.87    
     :            *(ALEV(L+1)-ALEV(L))/(PP(L+1)-PP(L))                       DERIVS.88    
            L=2                                                              DERIVS.89    
            CALL HUNT(PM,NL,PSM,L)                                           DERIVS.90    
            IF (L.LE.1) L=1                                                  DERIVS.91    
            IF (L.GE.NL) L=NL-1                                              BUGS3EC.20    
            BOUNDM=ALEV(L)+(PSM-PM(L))                                       DERIVS.92    
     :            *(ALEV(L+1)-ALEV(L))/(PM(L+1)-PM(L))                       DERIVS.93    
            BOUND=S*BOUNDP+OMS*BOUNDM                                        DERIVS.94    
            DPSDT=(BOUNDP-BOUNDM)/(T2-T1)                                    DERIVS.95    
         ENDIF                                                               DERIVS.96    
      ENDIF                                                                  DERIVS.97    
C                                                                            DERIVS.98    
C     Find L such that:-                                                     DERIVS.99    
C     Values ascend with L   ALEV(L) < Y(3) < ALEV(L+1)                      DERIVS.100   
C                                                                            DERIVS.101   
      L=LSAV                                                                 DERIVS.102   
      CALL HUNT(ALEV,NL,Y(3),L)                                              DERIVS.103   
C                                                                            DERIVS.104   
C     For extrapolation near the top/bottom boundaries.                      DERIVS.105   
C                                                                            DERIVS.106   
      LSAV=L                                                                 DERIVS.107   
      IF (L.LT.2) L=2                                                        DERIVS.108   
      IF (L.GT.(NL-2)) L=NL-2                                                DERIVS.109   
      IF (LEVZT1) THEN                                                       DERIVS.110   
         IF (ALEV(L+1).GT.BOUND) L=L-2                                       DERIVS.111   
      ELSE                                                                   DERIVS.112   
         IF (ALEV(L).GT.BOUND) L=L+2                                         DERIVS.113   
      ENDIF                                                                  DERIVS.114   
C                                                                            DERIVS.115   
C     Find grid point values for U,V at times tminus and                     DERIVS.116   
C     tplus, at the particles' positions.                                    DERIVS.117   
C     Interpolation for case when particle lies in a grid box with           DERIVS.118   
C     field values on all corners, and extrapolation near the                DERIVS.119   
C     boundaries.                                                            DERIVS.120   
C     Remember that U,V are stored on full levels.                           DERIVS.121   
C                                                                            DERIVS.122   
      CALL INTERP(URHS,DYDT(1),M,J,L,P,Q,Y(3),MP,JM,JHEM,JHEMM)              DERIVS.123   
      CALL INTERP(VRHS,DYDT(2),M,J,L,P,Q,Y(3),MP,JM,JHEM,JHEMM)              DERIVS.124   
      CALL INTERP(UM,DYDTM(1),M,J,L,P,Q,Y(3),MP,JM,JHEM,JHEMM)               DERIVS.125   
      CALL INTERP(VM,DYDTM(2),M,J,L,P,Q,Y(3),MP,JM,JHEM,JHEMM)               DERIVS.126   
C                                                                            DERIVS.127   
      IF (ILEVTYPE.EQ.0) THEN                                                DERIVS.128   
C                                                                            DERIVS.129   
C     For ECMWF, RSGCM and UM data in eta coordinates                        DERIVS.130   
C     vertical velocity, etadot, is on half-levels.                          DERIVS.131   
C                                                                            DERIVS.132   
C     Find LH such that:-                                                    DERIVS.133   
C     Values ascend with LH    ALEVH(LH) < Y(3) < ALEVH(LH+1)                DERIVS.134   
C                                                                            DERIVS.135   
         LH=LHSAV                                                            DERIVS.136   
         CALL HUNT(ALEVH,NL+1,Y(3),LH)                                       DERIVS.137   
         LHSAV=LH                                                            DERIVS.138   
         IF(LHSAV.LE.1) LHSAV=2                                              DERIVS.139   
C                                                                            DERIVS.140   
C     For extrapolation near the top/bottom boundaries.                      DERIVS.141   
C                                                                            DERIVS.142   
         IF (LH.LT.2) LH=2                                                   DERIVS.143   
         IF (LH.GT.(NL-1)) LH=NL-1                                           DERIVS.144   
C                                                                            DERIVS.145   
C     Find grid point values for SDOT, at times tminus and                   DERIVS.146   
C     tplus, at the particles' positions.                                    DERIVS.147   
C     Remember that SDOT is stored on half levels.                           DERIVS.148   
C                                                                            DERIVS.149   
         CALL HINTERP(SDRHS,DYDT(3),MT,JT,LH,PT,QT,Y(3)                      DERIVS.150   
     :        ,MPT,JMT,JHEMT,JHEMMT)                                         DERIVS.151   
         CALL HINTERP(SDM,DYDTM(3),MT,JT,LH,PT,QT,Y(3)                       DERIVS.152   
     :        ,MPT,JMT,JHEMT,JHEMMT)                                         DERIVS.153   
      ELSE                                                                   DERIVS.154   
C                                                                            DERIVS.155   
C     The vertical velocities are given on the same levels as all            DERIVS.156   
C     other fields. BOUND denotes the value of vertical coordinate           DERIVS.157   
C     at the lower boundary and DPSDT the vertical velocity.                 DERIVS.158   
C                                                                            DERIVS.159   
         IEDGE=0                                                             DERIVS.160   
         ZEDGE=0.                                                            DERIVS.161   
         WEDGE=0.                                                            DERIVS.162   
         IF (LSAV.LE.1) L=1                                                  DERIVS.163   
         IF (LSAV.GE.(NL-1)) L=NL-1                                          DERIVS.164   
         IF (.NOT.LEVZT1) THEN                                               DERIVS.165   
            IF (ALEV(L).GT.BOUND) THEN                                       DERIVS.166   
               L=L+1                                                         DERIVS.167   
               IEDGE=1                                                       DERIVS.168   
               ZEDGE=BOUND                                                   DERIVS.169   
               WEDGE=DPSDT                                                   DERIVS.170   
            ENDIF                                                            DERIVS.171   
            IF (L.EQ.1) THEN                                                 DERIVS.172   
               IEDGE=1                                                       DERIVS.173   
               ZEDGE=BOUND                                                   DERIVS.174   
               WEDGE=DPSDT                                                   DERIVS.175   
            ENDIF                                                            DERIVS.176   
            IF (LSAV.EQ.(NL-1)) IEDGE=2                                      DERIVS.177   
         ELSE                                                                DERIVS.178   
            IF (ALEV(L+1).GT.BOUND) THEN                                     DERIVS.179   
               L=L-1                                                         DERIVS.180   
               IEDGE=2                                                       DERIVS.181   
               ZEDGE=BOUND                                                   DERIVS.182   
               WEDGE=DPSDT                                                   DERIVS.183   
            ENDIF                                                            DERIVS.184   
            IF (LSAV.EQ.(NL-1)) THEN                                         DERIVS.185   
               IEDGE=2                                                       DERIVS.186   
               ZEDGE=BOUND                                                   DERIVS.187   
               WEDGE=DPSDT                                                   DERIVS.188   
            ENDIF                                                            DERIVS.189   
            IF (LSAV.EQ.1) IEDGE=1                                           DERIVS.190   
         ENDIF                                                               DERIVS.191   
         CALL WINTERP(SDRHS,DYDT(3),M,J,L,P,Q,Y(3)                           DERIVS.192   
     :        ,MP,JM,JHEM,JHEMM,IEDGE,ZEDGE,WEDGE)                           DERIVS.193   
         CALL WINTERP(SDM,DYDTM(3),M,J,L,P,Q,Y(3)                            DERIVS.194   
     :        ,MP,JM,JHEM,JHEMM,IEDGE,ZEDGE,WEDGE)                           DERIVS.195   
      ENDIF                                                                  DERIVS.196   
C                                                                            DERIVS.197   
C     Linear interpolation between tminus and tplus to particle's time.      DERIVS.198   
C                                                                            DERIVS.199   
      DO 40 I=1,3                                                            DERIVS.200   
         DYDT(I)=S*DYDT(I)+OMS*DYDTM(I)                                      DERIVS.201   
 40   CONTINUE                                                               DERIVS.202   
C                                                                            DERIVS.203   
      RETURN                                                                 DERIVS.204   
      END                                                                    DERIVS.205   
C     ******************************************************************     DERIVS.206   
      SUBROUTINE FINDSW(Y,XLAM,DLAM,ALAT                                     FINDSW.2     
     :                 ,M,MP,J,JM,P,Q,JHEM,JHEMM)                            FINDSW.3     
C                                                                            FINDSW.4     
C     Finds the indices describing the South-West corner of                  FINDSW.5     
C     the grid box surrounding the particle.                                 FINDSW.6     
C                                                                            FINDSW.7     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      REAL Y(3),P,Q,YMOD,XLAM,DLAM,ALAT(JGG)                                 FINDSW.10    
      INTEGER M,MP,MINT,J,JM,JHEM,JHEMM                                      FINDSW.11    
C                                                                            FINDSW.12    
C     Remember that longitude is cyclic with MOCT fold symmetry.             FINDSW.13    
C                                                                            FINDSW.14    
      YMOD=Y(1)-XLAM-DLAM                                                    FINDSW.15    
      NCYCLE=INT(YMOD/PI2DM)                                                 FINDSW.16    
      YMOD=YMOD-NCYCLE*PI2DM                                                 FINDSW.17    
      MINT=INT(YMOD/DLAM)                                                    FINDSW.18    
      M=MINT+1                                                               FINDSW.19    
C                                                                            FINDSW.20    
C     Remember cyclic in longitude index for point to the East.              FINDSW.21    
C                                                                            FINDSW.22    
      IF (M.EQ.MG) THEN                                                      FINDSW.23    
         MP=1                                                                FINDSW.24    
      ELSE                                                                   FINDSW.25    
         MP=M+1                                                              FINDSW.26    
      ENDIF                                                                  FINDSW.27    
C                                                                            FINDSW.28    
C     Use previous grid point as first guess for the new grid point at       FINDSW.29    
C     vertex 1 of the grid box surrounding the particle.                     FINDSW.30    
C                                                                            FINDSW.31    
      JM=JSAV-1                                                              FINDSW.32    
C                                                                            FINDSW.33    
C     Finds J such that:-                                                    FINDSW.34    
C     Values descend with J  ALAT(J-1) > Y(2) > ALAT(J)                      FINDSW.35    
C                                                                            FINDSW.36    
      CALL HUNT(ALAT,JGG,Y(2),JM)                                            FINDSW.37    
      J=JM+1                                                                 FINDSW.38    
C                                                                            FINDSW.39    
C     Save the grid point for the next particle.                             FINDSW.40    
C                                                                            FINDSW.41    
      JSAV=J                                                                 FINDSW.42    
      IF(JSAV.LE.1) JSAV=2                                                   FINDSW.43    
C                                                                            FINDSW.44    
C     For extrapolation near SP or equator and also near NP.                 FINDSW.45    
C                                                                            FINDSW.46    
      IF (J.EQ.JGG+1) J=JGG                                                  FINDSW.47    
      IF (J.EQ.1) J=2                                                        FINDSW.48    
C                                                                            FINDSW.49    
C     Set up the horizontal linear interpolation weights.                    FINDSW.50    
C                                                                            FINDSW.51    
      P=(YMOD-MINT*DLAM)/DLAM                                                FINDSW.52    
      DPHI=ALAT(J-1)-ALAT(J)                                                 FINDSW.53    
      IF (DPHI.EQ.0.) THEN                                                   FINDSW.54    
         J=J-1                                                               FINDSW.55    
         DPHI=ALAT(J-1)-ALAT(J)                                              FINDSW.56    
      ENDIF                                                                  FINDSW.57    
      Q=(Y(2)-ALAT(J))/DPHI                                                  FINDSW.58    
C                                                                            FINDSW.59    
C     Set up as if for hemispheric mode and make appropriate changes         FINDSW.60    
C     if particles lie in the Southern hemisphere.                           FINDSW.61    
C                                                                            FINDSW.62    
      JM=J-1                                                                 FINDSW.63    
      JHEM=1                                                                 FINDSW.64    
      JHEMM=1                                                                FINDSW.65    
      IF (J.GT.JG) THEN                                                      FINDSW.66    
         JHEM=2                                                              FINDSW.67    
         J=JGGP-J                                                            FINDSW.68    
         IF (JM.GT.JG) THEN                                                  FINDSW.69    
            JHEMM=2                                                          FINDSW.70    
            JM=JGGP-JM                                                       FINDSW.71    
         ENDIF                                                               FINDSW.72    
      ENDIF                                                                  FINDSW.73    
C                                                                            FINDSW.74    
      RETURN                                                                 FINDSW.75    
      END                                                                    FINDSW.76    
C     *****************************************************************      FINDSW.77    
      SUBROUTINE HUNT(XX,N,X,JLO)                                            HUNT.2     
C                                                                            HUNT.3     
C     Given an array XX of length N, and given a value X, returns a          HUNT.4     
C     value JLO such that X is between XX(JLO) and XX(JLO+1). XX must        HUNT.5     
C     be monotonic, either increasing or decreasing.                         HUNT.6     
C     JLO=0 or JLO=N is returned to indicate that X is out of range.         HUNT.7     
C     JLO on input is taken as the initial guess for JLO on output.          HUNT.8     
C                                                                            HUNT.9     
C     From Numerical Recipes.                                                HUNT.10    
C                                                                            HUNT.11    
      DIMENSION XX(N)                                                        HUNT.12    
      LOGICAL ASCEND                                                         HUNT.13    
C                                                                            HUNT.14    
      ASCEND=XX(N).GT.XX(1)                                                  HUNT.15    
C                                                                            HUNT.16    
C     Is input guess useful? If not go directly to disection.                HUNT.17    
C                                                                            HUNT.18    
      IF(JLO.LE.0.OR.JLO.GT.N) THEN                                          HUNT.19    
         JLO=0                                                               HUNT.20    
         JHI=N+1                                                             HUNT.21    
         GO TO 3                                                             HUNT.22    
      ENDIF                                                                  HUNT.23    
C                                                                            HUNT.24    
C     Set the hunting increment.                                             HUNT.25    
C                                                                            HUNT.26    
      INC=1                                                                  HUNT.27    
C                                                                            HUNT.28    
C     Hunt up.                                                               HUNT.29    
C                                                                            HUNT.30    
      IF(X.GE.XX(JLO).EQV.ASCEND) THEN                                       HUNT.31    
 1       JHI=JLO+INC                                                         HUNT.32    
         IF(JHI.GT.N) THEN                                                   HUNT.33    
            JHI=N+1                                                          HUNT.34    
         ELSE IF(X.GE.XX(JHI).EQV.ASCEND) THEN                               HUNT.35    
            JLO=JHI                                                          HUNT.36    
            INC=INC+INC                                                      HUNT.37    
            GO TO 1                                                          HUNT.38    
         ENDIF                                                               HUNT.39    
      ELSE                                                                   HUNT.40    
C                                                                            HUNT.41    
C     Hunt down.                                                             HUNT.42    
C                                                                            HUNT.43    
         JHI=JLO                                                             HUNT.44    
 2       JLO=JHI-INC                                                         HUNT.45    
         IF(JLO.LT.1) THEN                                                   HUNT.46    
            JLO=0                                                            HUNT.47    
         ELSE IF(X.LT.XX(JLO).EQV.ASCEND) THEN                               HUNT.48    
            JHI=JLO                                                          HUNT.49    
            INC=INC+INC                                                      HUNT.50    
            GO TO 2                                                          HUNT.51    
         ENDIF                                                               HUNT.52    
      ENDIF                                                                  HUNT.53    
C                                                                            HUNT.54    
C     Hunt is done so begin the final bisection phase.                       HUNT.55    
C                                                                            HUNT.56    
 3    IF(JHI-JLO.EQ.1) RETURN                                                HUNT.57    
      JM=(JHI+JLO)/2                                                         HUNT.58    
      IF(X.GT.XX(JM).EQV.ASCEND) THEN                                        HUNT.59    
         JLO=JM                                                              HUNT.60    
      ELSE                                                                   HUNT.61    
         JHI=JM                                                              HUNT.62    
      ENDIF                                                                  HUNT.63    
      GO TO 3                                                                HUNT.64    
      END                                                                    HUNT.65    
C     ******************************************************************     HUNT.66    
      SUBROUTINE FINDALEV(FIN,POUT,M,MP,J,JM,P,Q,JHEM,JHEMM)                 FINDALEV.2     
C                                                                            FINDALEV.3     
C     To find a field on levels at particle's horizontal position.           FINDALEV.4     
C                                                                            FINDALEV.5     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      REAL FIN(IGDLA),POUT(NL),P,Q,OMP,OMQ                                   FINDALEV.9     
      INTEGER M,MP,J,JM,JHEM,JHEMM                                           FINDALEV.10    
C                                                                            FINDALEV.11    
C     Horizontal interpolation of (non-dimensionalised)                      FINDALEV.12    
C     field on model levels to particle's horizontal position.               FINDALEV.13    
C                                                                            FINDALEV.14    
      OMP=1.-P                                                               FINDALEV.15    
      OMQ=1.-Q                                                               FINDALEV.16    
      DO 10 L=1,NL                                                           FINDALEV.17    
         F1=FIN(M+(JHEM-1)*MGPP+(L-1)*IGC+(J-1)*IGD)                         FINDALEV.18    
         F2=FIN(MP+(JHEM-1)*MGPP+(L-1)*IGC+(J-1)*IGD)                        FINDALEV.19    
         F3=FIN(MP+(JHEMM-1)*MGPP+(L-1)*IGC+(JM-1)*IGD)                      FINDALEV.20    
         F4=FIN(M+(JHEMM-1)*MGPP+(L-1)*IGC+(JM-1)*IGD)                       FINDALEV.21    
         POUT(L)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                         FINDALEV.22    
 10   CONTINUE                                                               FINDALEV.23    
C                                                                            FINDALEV.24    
      RETURN                                                                 FINDALEV.25    
      END                                                                    FINDALEV.26    
C     ****************************************************************       FINDALEV.27    
      SUBROUTINE INTERP(FIN,FOUT,M,J,L,P,Q,SIG,MP,JM,JHEM,JHEMM)             INTERP.2     
C                                                                            INTERP.3     
C     Horizontal linear interpolation within a complete grid square          INTERP.4     
C     with field values on all corners.                                      INTERP.5     
C     Cubic vertical interpolation.                                          INTERP.6     
C     Serves for extrapolation when the box has been moved in from the       INTERP.7     
C     boundary.                                                              INTERP.8     
C                                                                            INTERP.9     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      REAL FIN(MGPP,NHEM,NL,JG),FOUT,P,Q,OMP,OMQ,XA(4),YA(4),SIG             INTERP.13    
      INTEGER M,MP,J,L,JM,JHEM,JHEMM                                         INTERP.14    
C                                                                            INTERP.15    
      OMP=1-P                                                                INTERP.16    
      OMQ=1-Q                                                                INTERP.17    
C                                                                            INTERP.18    
C     Horizontal linear interpolation for all 4 points in the vertical.      INTERP.19    
C                                                                            INTERP.20    
      DO 10 IPT=1,4                                                          INTERP.21    
         LPT=L+IPT-2                                                         INTERP.22    
         F1=FIN(M,JHEM,LPT,J)                                                INTERP.23    
         F2=FIN(MP,JHEM,LPT,J)                                               INTERP.24    
         F3=FIN(MP,JHEMM,LPT,JM)                                             INTERP.25    
         F4=FIN(M,JHEMM,LPT,JM)                                              INTERP.26    
         XA(IPT)=ALEV(LPT)                                                   INTERP.27    
         YA(IPT)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                         INTERP.28    
 10   CONTINUE                                                               INTERP.29    
C                                                                            INTERP.30    
C     Cubic vertical interpolation.                                          INTERP.31    
C                                                                            INTERP.32    
      CALL POLINT(XA,YA,4,SIG,FOUT,DY)                                       INTERP.33    
C                                                                            INTERP.34    
      RETURN                                                                 INTERP.35    
      END                                                                    INTERP.36    
C     ****************************************************************       INTERP.37    
      SUBROUTINE HINTERP(FIN,FOUT,M,J,LH,P,Q,SIG,MP,JM,JHEM,JHEMM)           HINTERP.2     
C                                                                            HINTERP.3     
C     Interpolation for vertical velocity between half-levels.               HINTERP.4     
C                                                                            HINTERP.5     
C     NOTE: Half levels range from p=0 (LH=1) to p=psurf (LH=NL+1).          HINTERP.6     
C     However vertical velocity only defined on half-levels                  HINTERP.7     
C     LH=2 to LH=NL+1 with level index LH-1.                                 HINTERP.8     
C                                                                            HINTERP.9     
C     Horizontal linear interpolation within a complete grid square          HINTERP.10    
C     with field values on all corners.                                      HINTERP.11    
C     Cubic vertical interpolation.                                          HINTERP.12    
C     Serves for extrapolation when the box has been moved in from the       HINTERP.13    
C     boundary.                                                              HINTERP.14    
C                                                                            HINTERP.15    
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      REAL FIN(MGPP,NHEM,NL,JG),FOUT,P,Q,OMP,OMQ,XA(4),YA(4),SIG             HINTERP.19    
      INTEGER M,MP,J,LH,JM,JHEM,JHEMM                                        HINTERP.20    
C                                                                            HINTERP.21    
      OMP=1-P                                                                HINTERP.22    
      OMQ=1-Q                                                                HINTERP.23    
C                                                                            HINTERP.24    
C     Find the values on each corner as numbered in notes for all 4          HINTERP.25    
C     points in the vertical.                                                HINTERP.26    
C                                                                            HINTERP.27    
      IF (LH.EQ.2) THEN                                                      HINTERP.28    
C                                                                            HINTERP.29    
C     Vertical velocity extrapolation at upper boundary only.                HINTERP.30    
C     Use b.c. : sgotg=0 at eta=0.                                           HINTERP.31    
C                                                                            HINTERP.32    
         XA(1)=ALEVH(1)                                                      HINTERP.33    
         YA(1)=0.                                                            HINTERP.34    
         DO 10 IPT=1,3                                                       HINTERP.35    
            LPT=IPT+1                                                        HINTERP.36    
            F1=FIN(M,JHEM,IPT,J)                                             HINTERP.37    
            F2=FIN(MP,JHEM,IPT,J)                                            HINTERP.38    
            F3=FIN(MP,JHEMM,IPT,JM)                                          HINTERP.39    
            F4=FIN(M,JHEMM,IPT,JM)                                           HINTERP.40    
            XA(LPT)=ALEVH(LPT)                                               HINTERP.41    
            YA(LPT)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                      HINTERP.42    
 10      CONTINUE                                                            HINTERP.43    
      ELSE                                                                   HINTERP.44    
C                                                                            HINTERP.45    
C     Vertical velocity extrapolation in interior or at                      HINTERP.46    
C     lower boundary (for LH=NL-1). In latter case use value                 HINTERP.47    
C     of sdotg on eta=1 (=0 if particle positions and velocities             HINTERP.48    
C     are described in eta coordinates).                                     HINTERP.49    
C                                                                            HINTERP.50    
         DO 30 IPT=1,4                                                       HINTERP.51    
            LPT=LH+IPT-2                                                     HINTERP.52    
            F1=FIN(M,JHEM,LPT-1,J)                                           HINTERP.53    
            F2=FIN(MP,JHEM,LPT-1,J)                                          HINTERP.54    
            F3=FIN(MP,JHEMM,LPT-1,JM)                                        HINTERP.55    
            F4=FIN(M,JHEMM,LPT-1,JM)                                         HINTERP.56    
            XA(IPT)=ALEVH(LPT)                                               HINTERP.57    
            YA(IPT)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                      HINTERP.58    
 30      CONTINUE                                                            HINTERP.59    
      ENDIF                                                                  HINTERP.60    
C                                                                            HINTERP.61    
C     Cubic vertical interpolation.                                          HINTERP.62    
C                                                                            HINTERP.63    
      CALL POLINT(XA,YA,4,SIG,FOUT,DY)                                       HINTERP.64    
C                                                                            HINTERP.65    
      RETURN                                                                 HINTERP.66    
      END                                                                    HINTERP.67    
C     ****************************************************************       HINTERP.68    
      SUBROUTINE WINTERP(FIN,FOUT,M,J,L,P,Q,SIG                              WINTERP.2     
     :     ,MP,JM,JHEM,JHEMM,IEDGE,ZEDGE,WEDGE)                              WINTERP.3     
C                                                                            WINTERP.4     
C     Interpolation for vertical velocity between levels.                    WINTERP.5     
C                                                                            WINTERP.6     
C     NOTE: Vertical velocity is defined on levels ranging                   WINTERP.7     
C     from 1 to NL in eta (or p) coords.                                     WINTERP.8     
C                                                                            WINTERP.9     
C     IEDGE=0    denotes interior                                            WINTERP.10    
C     IEDGE=1    denotes boundary at low L end.                              WINTERP.11    
C     IEDGE=2    denotes boundary at high L end.                             WINTERP.12    
C                                                                            WINTERP.13    
C     ZEDGE=boundary position;   WEDGE=boundary velocity.                    WINTERP.14    
C                                                                            WINTERP.15    
C     Horizontal linear interpolation within a complete grid square          WINTERP.16    
C     with field values on all corners.                                      WINTERP.17    
C     Cubic vertical interpolation.                                          WINTERP.18    
C     Serves for extrapolation when the box has been moved in from the       WINTERP.19    
C     boundary.                                                              WINTERP.20    
C                                                                            WINTERP.21    
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      REAL FIN(MGPP,NHEM,NL,JG),FOUT,P,Q,OMP,OMQ,XA(4),YA(4),SIG             WINTERP.25    
     :    ,ZEDGE,WEDGE                                                       WINTERP.26    
      INTEGER M,MP,J,JM,JHEM,JHEMM,IEDGE                                     WINTERP.27    
C                                                                            WINTERP.28    
      OMP=1-P                                                                WINTERP.29    
      OMQ=1-Q                                                                WINTERP.30    
C                                                                            WINTERP.31    
C     Find the values on each corner as numbered in notes for all 4          WINTERP.32    
C     points in the vertical.                                                WINTERP.33    
C                                                                            WINTERP.34    
      IF (IEDGE.EQ.0) THEN                                                   WINTERP.35    
C                                                                            WINTERP.36    
C     Vertical velocity interpolation in interior.                           WINTERP.37    
C                                                                            WINTERP.38    
         DO 10 IPT=1,4                                                       WINTERP.39    
            LPT=L+IPT-2                                                      WINTERP.40    
            F1=FIN(M,JHEM,LPT,J)                                             WINTERP.41    
            F2=FIN(MP,JHEM,LPT,J)                                            WINTERP.42    
            F3=FIN(MP,JHEMM,LPT,JM)                                          WINTERP.43    
            F4=FIN(M,JHEMM,LPT,JM)                                           WINTERP.44    
            XA(IPT)=ALEV(LPT)                                                WINTERP.45    
            YA(IPT)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                      WINTERP.46    
 10      CONTINUE                                                            WINTERP.47    
      ELSE                                                                   WINTERP.48    
         IF (IEDGE.EQ.1) THEN                                                WINTERP.49    
C                                                                            WINTERP.50    
C     Vertical velocity extrapolation at low L boundary using b.c.           WINTERP.51    
C                                                                            WINTERP.52    
            XA(1)=ZEDGE                                                      WINTERP.53    
            YA(1)=WEDGE                                                      WINTERP.54    
            DO 20 IPT=2,4                                                    WINTERP.55    
               LPT=L+IPT-2                                                   WINTERP.56    
               F1=FIN(M,JHEM,LPT,J)                                          WINTERP.57    
               F2=FIN(MP,JHEM,LPT,J)                                         WINTERP.58    
               F3=FIN(MP,JHEMM,LPT,JM)                                       WINTERP.59    
               F4=FIN(M,JHEMM,LPT,JM)                                        WINTERP.60    
               XA(IPT)=ALEV(LPT)                                             WINTERP.61    
               YA(IPT)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                   WINTERP.62    
 20         CONTINUE                                                         WINTERP.63    
         ELSE                                                                WINTERP.64    
C                                                                            WINTERP.65    
C     Vertical velocity extrapolation at high L boundary using b.c.          WINTERP.66    
C                                                                            WINTERP.67    
            XA(4)=ZEDGE                                                      WINTERP.68    
            YA(4)=WEDGE                                                      WINTERP.69    
            DO 30 IPT=1,3                                                    WINTERP.70    
               LPT=L+IPT-2                                                   WINTERP.71    
               F1=FIN(M,JHEM,LPT,J)                                          WINTERP.72    
               F2=FIN(MP,JHEM,LPT,J)                                         WINTERP.73    
               F3=FIN(MP,JHEMM,LPT,JM)                                       WINTERP.74    
               F4=FIN(M,JHEMM,LPT,JM)                                        WINTERP.75    
               XA(IPT)=ALEV(LPT)                                             WINTERP.76    
               YA(IPT)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                   WINTERP.77    
 30         CONTINUE                                                         WINTERP.78    
         ENDIF                                                               WINTERP.79    
      ENDIF                                                                  WINTERP.80    
C                                                                            WINTERP.81    
C     Cubic vertical interpolation.                                          WINTERP.82    
C                                                                            WINTERP.83    
      CALL POLINT(XA,YA,4,SIG,FOUT,DY)                                       WINTERP.84    
C                                                                            WINTERP.85    
      RETURN                                                                 WINTERP.86    
      END                                                                    WINTERP.87    
C     ****************************************************************       WINTERP.88    
      SUBROUTINE POLINT(XA,YA,N,X,Y,DY)                                      POLINT.2     
C                                                                            POLINT.3     
C     Given arrays XA and YA, each of length N, and given a value X,         POLINT.4     
C     this routine returns a value Y, and an error estimate DY.              POLINT.5     
C     If P(X) is the polynomial degree N-1 such that                         POLINT.6     
C     P(XAi)=YAi,i=1,...,N, then the returned value Y=P(X).                  POLINT.7     
C                                                                            POLINT.8     
C              from Numerical Recipes, p.82.                                 POLINT.9     
C                                                                            POLINT.10    
      PARAMETER (NMAX=10)                                                    POLINT.11    
      DIMENSION XA(N),YA(N),C(NMAX),D(NMAX)                                  POLINT.12    
 6000 FORMAT(/'Two elements of XA are identical.')                           POLINT.13    
C                                                                            POLINT.14    
      NS=1                                                                   POLINT.15    
      DIF=ABS(X-XA(1))                                                       POLINT.16    
      DO 11 I=1,N                                                            POLINT.17    
         DIFT=ABS(X-XA(I))                                                   POLINT.18    
         IF (DIFT.LT.DIF) THEN                                               POLINT.19    
            NS=I                                                             POLINT.20    
            DIF=DIFT                                                         POLINT.21    
         ENDIF                                                               POLINT.22    
         C(I)=YA(I)                                                          POLINT.23    
         D(I)=YA(I)                                                          POLINT.24    
 11   CONTINUE                                                               POLINT.25    
      Y=YA(NS)                                                               POLINT.26    
      NS=NS-1                                                                POLINT.27    
      DO 13 M=1,N-1                                                          POLINT.28    
         DO 12 I=1,N-M                                                       POLINT.29    
            HO=XA(I)-X                                                       POLINT.30    
            HP=XA(I+M)-X                                                     POLINT.31    
            W=C(I+1)-D(I)                                                    POLINT.32    
            DEN=HO-HP                                                        POLINT.33    
            IF (DEN.EQ.0) THEN                                               POLINT.34    
               WRITE(6,6000)                                                 POLINT.35    
               STOP                 100                                      POLINT.36    
            ENDIF                                                            POLINT.37    
            DEN=W/DEN                                                        POLINT.38    
            D(I)=HP*DEN                                                      POLINT.39    
            C(I)=HO*DEN                                                      POLINT.40    
 12      CONTINUE                                                            POLINT.41    
         IF (2*NS.LT.N-M) THEN                                               POLINT.42    
            DY=C(NS+1)                                                       POLINT.43    
         ELSE                                                                POLINT.44    
            DY=D(NS)                                                         POLINT.45    
            NS=NS-1                                                          POLINT.46    
         ENDIF                                                               POLINT.47    
         Y=Y+DY                                                              POLINT.48    
 13   CONTINUE                                                               POLINT.49    
      RETURN                                                                 POLINT.50    
      END                                                                    POLINT.51    
C     ***************************************************************        POLINT.52    
      SUBROUTINE SETATTR(IPOS,ITELP)                                         SETATTR.2     
C                                                                            SETATTR.3     
C     Interpolates the attribute fields to the particles' positions.         SETATTR.4     
C                                                                            SETATTR.5     
C     IPOS is position marker for this release set.                          SETATTR.6     
C     ITELP is marker for current time element for this set.                 SETATTR.7     
C                                                                            SETATTR.8     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)                                       COMPSG.2     
C      PARAMETER(IGDLAP=1,IGCP=IGC)                                          COMPSG.3     
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)             COMPSG.4     
     :,BLETAM(IGCP,JG)                                                       SFCDATA.14    
C                                                                            COMPSG.5     
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/CLUSTERS/NCLUSTERS,IPOSN(MAXCLUS)                               CLUSTERS.2     
     :,IPOINTER(MAXCLUS)                                                     BUGS3EC.3     
     :,XCLUSTER(MAXCLUS),YCLUSTER(MAXCLUS),ZCLUSTER(MAXCLUS)                 CLUSTERS.3     
     :,XSPACE(MAXCLUS),YSPACE(MAXCLUS),ZSPACE(MAXCLUS)                       CLUSTERS.4     
     :,NXACR(MAXCLUS),NYACR(MAXCLUS),PHILIM,INISURF                          CLUSTERS.5     
C                                                                            CLUSTERS.6     
      REAL Y(3),P,Q,OMP,OMQ,DS,S,OMS,PSP,PSM,THACC                           SETATTR.17    
     :     ,XLAM,ALATUSE(JGG)                                                SETATTR.18    
     :     ,FIELD(IGDLA),OFIELD(IGDLA),FP,FM,PP,PM,PUP,PDOWN                 SETATTR.19    
     :     ,W2EARR(NL),ZPART,DETA,R,BOUND                                    ZATTR.40    
      INTEGER M,MP,J,L,JM,JHEM,JHEMM,ITYPE                                   SETATTR.20    
     :,IPOS,NTIME,ITELP,NLOOP,IEND,LH                                        SETATTR.21    
     :,ICL                                                                   BUGS3EC.40    
C                                                                            SETATTR.22    
C     Set the particle's attribute values.                                   SETATTR.23    
C     IATTRTYP(I)=                                                           SETATTR.24    
C     0     ;Surface pressure assigned to i'th attribute.                    SETATTR.25    
C     1     ;Temperature.                                                    SETATTR.26    
C     2     ;Potential temperature.                                          SETATTR.27    
C     3     ;Ertel potential vorticity.                                      SETATTR.28    
C     4     ;Specific humidity (LDRY=.FALSE.).                               SETATTR.29    
C     5     ;Tracer field no. NCHI(1) from history.                          SETATTR.30    
C     6     ;Tracer field no. NCHI(2) from history.                          SETATTR.31    
C                                                                            SETATTR.32    
      FM=0.                                                                  SETATTR.33    
      FP=0.                                                                  SETATTR.34    
      PSM=0.                                                                 PSIATTR.3     
      PSP=0.                                                                 PSIATTR.4     
      NLOOP=NJUMP                                                            SETATTR.35    
      IF (ITELP.EQ.1) NLOOP=1                                                SETATTR.36    
      IEND=NATTR                                                             SETATTR.37    
      IF (NATTR.EQ.0) IEND=IEND+1                                            SETATTR.38    
      DO 10 IATTR=1,IEND                                                     SETATTR.39    
         ITYPE=IATTRTYP(IATTR)                                               SETATTR.40    
         IF (LUGRID(IATTR)) THEN                                             SETATTR.41    
            XLAM=ZUBZX                                                       SETATTR.42    
            DO 20 J=1,JGG                                                    SETATTR.43    
               ALATUSE(J)=ALAT(J)                                            SETATTR.44    
 20         CONTINUE                                                         SETATTR.45    
         ELSE                                                                SETATTR.46    
            XLAM=ZTBZX                                                       SETATTR.47    
            DO 30 J=1,JGG                                                    SETATTR.48    
               ALATUSE(J)=ALATT(J)                                           SETATTR.49    
 30         CONTINUE                                                         SETATTR.50    
         ENDIF                                                               SETATTR.51    
         IF ((IATTR.LE.NATTR).AND.(ITYPE.LT.7)) THEN                         PSIATTR.5     
            ICHAN=NCGP(ITYPE)                                                SETATTR.53    
            CALL READATTR(ICHAN,FIELD)                                       SETATTR.54    
            IF (NLOOP.GT.1) THEN                                             SETATTR.55    
               ICHAN=ICHAN+MAXATTR                                           SETATTR.56    
               CALL READATTR(ICHAN,OFIELD)                                   SETATTR.57    
            ENDIF                                                            SETATTR.58    
         ENDIF                                                               SETATTR.59    
C                                                                            SETATTR.60    
C     Loop over particles.                                                   SETATTR.61    
C                                                                            SETATTR.62    
         DO 900 II=1,NPSET                                                   SETATTR.63    
            ICL=1                                                            BUGS3EC.41    
            DO 902 ICC=1,NCLUSTERS                                           BUGS3EC.42    
               IF (II.GE.IPOINTER(ICC)) THEN                                 BUGS3EC.43    
                  ICL=ICC                                                    BUGS3EC.44    
               ENDIF                                                         BUGS3EC.45    
  902       CONTINUE                                                         BUGS3EC.46    
            ILAB=IPOS+II                                                     SETATTR.64    
C                                                                            SETATTR.65    
C     Is the particle switched ON ?                                          SETATTR.66    
C                                                                            SETATTR.67    
            IF (POSN(ITELP,ILAB,3).GT.0.0) THEN                              SETATTR.68    
               S=1./FLOAT(NLOOP)                                             SETATTR.69    
               DS=S                                                          SETATTR.70    
               DO 910 IINTER=1,NLOOP                                         SETATTR.71    
                  NTIME=ITELP-NLOOP+IINTER                                   SETATTR.72    
                  OMS=1.-S                                                   SETATTR.73    
C                                                                            SETATTR.74    
C     Find the vertex of the grid box surrounding the particle which         SETATTR.75    
C     has the lowest longitude,latitude and sigma.                           SETATTR.76    
C                                                                            SETATTR.77    
                  Y(1)=POSN(NTIME,ILAB,1)                                    SETATTR.78    
                  Y(2)=POSN(NTIME,ILAB,2)                                    SETATTR.79    
                  Y(3)=POSN(NTIME,ILAB,3)                                    SETATTR.80    
                  CALL FINDSW(Y,XLAM,DLAM,ALATUSE                            SETATTR.81    
     :                 ,M,MP,J,JM,P,Q,JHEM,JHEMM)                            SETATTR.82    
C                                                                            SETATTR.83    
C     Find pressure on model levels if not a sigma-level model.              SETATTR.84    
C                                                                            SETATTR.85    
                  IF (ILEVTYPE.EQ.2) THEN                                    SETATTR.86    
                     CALL FINDALEV(PSGLA,ALEV,M,MP,J,JM,P,Q,JHEM,JHEMM)      SETATTR.87    
                  ENDIF                                                      SETATTR.88    
C                                                                            SETATTR.89    
C     Find L such that:-                                                     SETATTR.90    
C     Values ascend with L   ALEV(L) < Y(3) < ALEV(L+1).                     SETATTR.91    
C                                                                            SETATTR.92    
                  L=LSAV                                                     SETATTR.93    
                  CALL HUNT(ALEV,NL,Y(3),L)                                  SETATTR.94    
                  IF (L.LT.2) L=2                                            SETATTR.95    
                  LSAV=L                                                     SETATTR.96    
                  IF (L.GT.(NL-2)) L=NL-2                                    SETATTR.97    
C                                                                            SETATTR.98    
C     If isentropic initialisation has failed                                SETATTR.99    
C     turn the particle off.                                                 SETATTR.100   
C     This sometimes occurs where the isentropic                             SETATTR.101   
C     surface intersects the ground.                                         SETATTR.102   
C                                                                            SETATTR.103   
                  IF ((NTIME.EQ.1).AND.(INISURF.EQ.2)                        SETATTR.104   
     :                 .AND.(IATTR.EQ.1)) THEN                               SETATTR.105   
                     CALL INTERP(THGLA,THETA,M,J,L,P,Q,Y(3)                  SETATTR.106   
     :                    ,MP,JM,JHEM,JHEMM)                                 SETATTR.107   
                     THACC=5.E-4                                             BUGS3EC.47    
                     ERR=ABS(THETA-ZCLUSTER(ICL))                            SETATTR.111   
                     IF (ERR.GT.THACC) THEN                                  SETATTR.112   
 6000 FORMAT(/'Isentropic init failed for particle ',I5,'  Err ',E11.4)      BUGS3EC.48    
                        WRITE(LOUTP,6000) ILAB,ERR                           BUGS3EC.49    
                        POSN(NTIME,ILAB,3)=0.                                BUGS3EC.50    
                        GOTO 900                                             SETATTR.116   
                     ENDIF                                                   SETATTR.117   
                  ENDIF                                                      SETATTR.118   
C                                                                            SETATTR.119   
C     Calculate surface pressure at particles positions                      SETATTR.120   
C     if wanted as attribute or for pressure coordinate.                     SETATTR.121   
C                                                                            SETATTR.122   
                     OMP=1.-P                                                SETATTR.124   
                     OMQ=1.-Q                                                SETATTR.125   
                     F1=PLGLA(M+(JHEM-1)*MGPP,J)                             SETATTR.126   
                     F2=PLGLA(MP+(JHEM-1)*MGPP,J)                            SETATTR.127   
                     F3=PLGLA(MP+(JHEMM-1)*MGPP,JM)                          SETATTR.128   
                     F4=PLGLA(M+(JHEMM-1)*MGPP,JM)                           SETATTR.129   
                     PSP=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                 SETATTR.130   
                     IF (IINTER.LT.NLOOP) THEN                               SETATTR.131   
                        F1=PLGLAM(M+(JHEM-1)*MGPP,J)                         SETATTR.132   
                        F2=PLGLAM(MP+(JHEM-1)*MGPP,J)                        SETATTR.133   
                        F3=PLGLAM(MP+(JHEMM-1)*MGPP,JM)                      SETATTR.134   
                        F4=PLGLAM(M+(JHEMM-1)*MGPP,JM)                       SETATTR.135   
                        PSM=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1              SETATTR.136   
                     ENDIF                                                   SETATTR.137   
                  IF (ITYPE.EQ.100) THEN                                     PSIATTR.6     
                     FP=1000.*PSP                                            PSIATTR.7     
                     FM=1000.*PSM                                            PSIATTR.8     
                  ENDIF                                                      PSIATTR.9     
                  IF (ITYPE.EQ.142) THEN                                     SFCDATA.179   
                     F1=PRECST6HR(M+(JHEM-1)*MGPP,J)                         SFCDATA.180   
                     F2=PRECST6HR(MP+(JHEM-1)*MGPP,J)                        SFCDATA.181   
                     F3=PRECST6HR(MP+(JHEMM-1)*MGPP,JM)                      SFCDATA.182   
                     F4=PRECST6HR(M+(JHEMM-1)*MGPP,JM)                       SFCDATA.183   
                     FP=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                  SFCDATA.184   
C                                                                            SFCDATA.185   
C     Accumulated over interval THIST so no point time interpolating.        SFCDATA.186   
C                                                                            SFCDATA.187   
                     FM=FP                                                   SFCDATA.188   
                  ENDIF                                                      SFCDATA.189   
                  IF (ITYPE.EQ.143) THEN                                     SFCDATA.190   
                     F1=PRECIP6HR(M+(JHEM-1)*MGPP,J)                         SFCDATA.191   
                     F2=PRECIP6HR(MP+(JHEM-1)*MGPP,J)                        SFCDATA.192   
                     F3=PRECIP6HR(MP+(JHEMM-1)*MGPP,JM)                      SFCDATA.193   
                     F4=PRECIP6HR(M+(JHEMM-1)*MGPP,JM)                       SFCDATA.194   
                     FP=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                  SFCDATA.195   
C                                                                            SFCDATA.196   
C     Accumulated over interval THIST so no point time interpolating.        SFCDATA.197   
C                                                                            SFCDATA.198   
                     FM=FP                                                   SFCDATA.199   
                  ENDIF                                                      SFCDATA.200   
                  IF (ITYPE.EQ.182) THEN                                     SFCDATA.201   
                     F1=EVAP6HR(M+(JHEM-1)*MGPP,J)                           SFCDATA.202   
                     F2=EVAP6HR(MP+(JHEM-1)*MGPP,J)                          SFCDATA.203   
                     F3=EVAP6HR(MP+(JHEMM-1)*MGPP,JM)                        SFCDATA.204   
                     F4=EVAP6HR(M+(JHEMM-1)*MGPP,JM)                         SFCDATA.205   
                     FP=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                  SFCDATA.206   
C                                                                            SFCDATA.207   
C     Accumulated over interval THIST so no point time interpolating.        SFCDATA.208   
C                                                                            SFCDATA.209   
                     FM=FP                                                   SFCDATA.210   
                  ENDIF                                                      SFCDATA.211   
                  IF (ITYPE.EQ.258) THEN                                     SFCDATA.212   
                     F1=PCRAD6HR(M+(JHEM-1)*MGPP,J)                          SFCDATA.213   
                     F2=PCRAD6HR(MP+(JHEM-1)*MGPP,J)                         SFCDATA.214   
                     F3=PCRAD6HR(MP+(JHEMM-1)*MGPP,JM)                       SFCDATA.215   
                     F4=PCRAD6HR(M+(JHEMM-1)*MGPP,JM)                        SFCDATA.216   
                     FP=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                  SFCDATA.217   
C                                                                            SFCDATA.218   
C     Accumulated over interval THIST so no point time interpolating.        SFCDATA.219   
C                                                                            SFCDATA.220   
                     FM=FP                                                   SFCDATA.221   
                  ENDIF                                                      SFCDATA.222   
                  IF (ITYPE.EQ.159) THEN                                     SFCDATA.223   
                     F1=BLHEIGHT(M+(JHEM-1)*MGPP,J)                          SFCDATA.224   
                     F2=BLHEIGHT(MP+(JHEM-1)*MGPP,J)                         SFCDATA.225   
                     F3=BLHEIGHT(MP+(JHEMM-1)*MGPP,JM)                       SFCDATA.226   
                     F4=BLHEIGHT(M+(JHEMM-1)*MGPP,JM)                        SFCDATA.227   
                     FP=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                  SFCDATA.228   
                     IF (IINTER.LT.NLOOP) THEN                               SFCDATA.229   
                        F1=BLHEIGHTM(M+(JHEM-1)*MGPP,J)                      SFCDATA.230   
                        F2=BLHEIGHTM(MP+(JHEM-1)*MGPP,J)                     SFCDATA.231   
                        F3=BLHEIGHTM(MP+(JHEMM-1)*MGPP,JM)                   SFCDATA.232   
                        F4=BLHEIGHTM(M+(JHEMM-1)*MGPP,JM)                    SFCDATA.233   
                        FM=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1               SFCDATA.234   
                     ENDIF                                                   SFCDATA.235   
                  ENDIF                                                      SFCDATA.236   
                  IF (ITYPE.EQ.167) THEN                                     SFCDATA.237   
                     F1=TEMP2M(M+(JHEM-1)*MGPP,J)                            SFCDATA.238   
                     F2=TEMP2M(MP+(JHEM-1)*MGPP,J)                           SFCDATA.239   
                     F3=TEMP2M(MP+(JHEMM-1)*MGPP,JM)                         SFCDATA.240   
                     F4=TEMP2M(M+(JHEMM-1)*MGPP,JM)                          SFCDATA.241   
                     FP=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                  SFCDATA.242   
                     IF (IINTER.LT.NLOOP) THEN                               SFCDATA.243   
                        F1=TEMP2MM(M+(JHEM-1)*MGPP,J)                        SFCDATA.244   
                        F2=TEMP2MM(MP+(JHEM-1)*MGPP,J)                       SFCDATA.245   
                        F3=TEMP2MM(MP+(JHEMM-1)*MGPP,JM)                     SFCDATA.246   
                        F4=TEMP2MM(M+(JHEMM-1)*MGPP,JM)                      SFCDATA.247   
                        FM=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1               SFCDATA.248   
                     ENDIF                                                   SFCDATA.249   
                  ENDIF                                                      SFCDATA.250   
                  IF (ITYPE.EQ.168) THEN                                     SFCDATA.251   
                     F1=TDEW2M(M+(JHEM-1)*MGPP,J)                            SFCDATA.252   
                     F2=TDEW2M(MP+(JHEM-1)*MGPP,J)                           SFCDATA.253   
                     F3=TDEW2M(MP+(JHEMM-1)*MGPP,JM)                         SFCDATA.254   
                     F4=TDEW2M(M+(JHEMM-1)*MGPP,JM)                          SFCDATA.255   
                     FP=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                  SFCDATA.256   
                     IF (IINTER.LT.NLOOP) THEN                               SFCDATA.257   
                        F1=TDEW2MM(M+(JHEM-1)*MGPP,J)                        SFCDATA.258   
                        F2=TDEW2MM(MP+(JHEM-1)*MGPP,J)                       SFCDATA.259   
                        F3=TDEW2MM(MP+(JHEMM-1)*MGPP,JM)                     SFCDATA.260   
                        F4=TDEW2MM(M+(JHEMM-1)*MGPP,JM)                      SFCDATA.261   
                        FM=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1               SFCDATA.262   
                     ENDIF                                                   SFCDATA.263   
                  ENDIF                                                      SFCDATA.264   
                  IF (ITYPE.EQ.186) THEN                                     SFCDATA.265   
                     F1=ALLC(M+(JHEM-1)*MGPP,J)                              SFCDATA.266   
                     F2=ALLC(MP+(JHEM-1)*MGPP,J)                             SFCDATA.267   
                     F3=ALLC(MP+(JHEMM-1)*MGPP,JM)                           SFCDATA.268   
                     F4=ALLC(M+(JHEMM-1)*MGPP,JM)                            SFCDATA.269   
                     FP=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                  SFCDATA.270   
                     IF (IINTER.LT.NLOOP) THEN                               SFCDATA.271   
                        F1=ALLCM(M+(JHEM-1)*MGPP,J)                          SFCDATA.272   
                        F2=ALLCM(MP+(JHEM-1)*MGPP,J)                         SFCDATA.273   
                        F3=ALLCM(MP+(JHEMM-1)*MGPP,JM)                       SFCDATA.274   
                        F4=ALLCM(M+(JHEMM-1)*MGPP,JM)                        SFCDATA.275   
                        FM=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1               SFCDATA.276   
                     ENDIF                                                   SFCDATA.277   
                  ENDIF                                                      SFCDATA.278   
                  IF (ITYPE.EQ.187) THEN                                     SFCDATA.279   
                     F1=AMLC(M+(JHEM-1)*MGPP,J)                              SFCDATA.280   
                     F2=AMLC(MP+(JHEM-1)*MGPP,J)                             SFCDATA.281   
                     F3=AMLC(MP+(JHEMM-1)*MGPP,JM)                           SFCDATA.282   
                     F4=AMLC(M+(JHEMM-1)*MGPP,JM)                            SFCDATA.283   
                     FP=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                  SFCDATA.284   
                     IF (IINTER.LT.NLOOP) THEN                               SFCDATA.285   
                        F1=AMLCM(M+(JHEM-1)*MGPP,J)                          SFCDATA.286   
                        F2=AMLCM(MP+(JHEM-1)*MGPP,J)                         SFCDATA.287   
                        F3=AMLCM(MP+(JHEMM-1)*MGPP,JM)                       SFCDATA.288   
                        F4=AMLCM(M+(JHEMM-1)*MGPP,JM)                        SFCDATA.289   
                        FM=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1               SFCDATA.290   
                     ENDIF                                                   SFCDATA.291   
                  ENDIF                                                      SFCDATA.292   
                  IF (ITYPE.EQ.188) THEN                                     SFCDATA.293   
                     F1=AHLC(M+(JHEM-1)*MGPP,J)                              SFCDATA.294   
                     F2=AHLC(MP+(JHEM-1)*MGPP,J)                             SFCDATA.295   
                     F3=AHLC(MP+(JHEMM-1)*MGPP,JM)                           SFCDATA.296   
                     F4=AHLC(M+(JHEMM-1)*MGPP,JM)                            SFCDATA.297   
                     FP=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1                  SFCDATA.298   
                     IF (IINTER.LT.NLOOP) THEN                               SFCDATA.299   
                        F1=AHLCM(M+(JHEM-1)*MGPP,J)                          SFCDATA.300   
                        F2=AHLCM(MP+(JHEM-1)*MGPP,J)                         SFCDATA.301   
                        F3=AHLCM(MP+(JHEMM-1)*MGPP,JM)                       SFCDATA.302   
                        F4=AHLCM(M+(JHEMM-1)*MGPP,JM)                        SFCDATA.303   
                        FM=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1               SFCDATA.304   
                     ENDIF                                                   SFCDATA.305   
                  ENDIF                                                      SFCDATA.306   
C                                                                            SETATTR.139   
C     Assign attributes.                                                     SETATTR.140   
C                                                                            SETATTR.141   
                  IF (IATTR.LE.NATTR) THEN                                   SETATTR.142   
                     IF (ITYPE.LT.100) THEN                                  PSIATTR.10    
C                                                                            PSIATTR.11    
C     Multi-level attribute fields.                                          PSIATTR.12    
C                                                                            PSIATTR.13    
                     IF (ITYPE.EQ.10) THEN                                   ZATTR.41    
                        CALL FINDALEV(W2ETA,W2EARR,M,MP,J,JM                 ZATTR.42    
     :                       ,P,Q,JHEM,JHEMM)                                ZATTR.43    
                        DO 50 LL=1,NL                                        ZATTR.44    
                           W2EARR(LL)=1./W2EARR(LL)                          ZATTR.45    
 50                     CONTINUE                                             ZATTR.46    
C                                                                            ZATTR.47    
C     Vertical integral to find height of particle (m) using                 ZATTR.48    
C     Trapezium rule.                                                        ZATTR.49    
C                                                                            ZATTR.50    
                        IF (ILEVTYPE.EQ.1) THEN                              ZATTR.51    
                           BOUND=S*PSP+OMS*PSM                               ZATTR.52    
                        ELSE                                                 ZATTR.53    
                           BOUND=1.                                          ZATTR.54    
                        ENDIF	                                               ZATTR.55    
                        LGR=NL                                               ZATTR.56    
                        IF (ALEV(NL).GT.BOUND) LGR=NL-1                      ZATTR.57    
                        ZPART=W2EARR(LGR)*(BOUND-ALEV(LGR))                  ZATTR.58    
                        IF (LSAV.LT.LGR-1) THEN                              ZATTR.59    
                           DO 60 LL=LGR-1,LSAV+1,-1                          ZATTR.60    
                              ZPART=ZPART+0.5*(W2EARR(LL+1)+W2EARR(LL))      ZATTR.61    
     :                             *(ALEV(LL+1)-ALEV(LL))                    ZATTR.62    
 60                        CONTINUE                                          ZATTR.63    
                           DETA=ALEV(LSAV+1)-Y(3)                            ZATTR.64    
                           R=DETA/(ALEV(LSAV+1)-ALEV(LSAV))                  ZATTR.65    
                           ZPART=ZPART+0.5*DETA                              ZATTR.66    
     :                          *((2.-R)*W2EARR(LSAV+1)+R*W2EARR(LSAV))      ZATTR.67    
                        ELSEIF (LSAV.EQ.LGR-1) THEN                          ZATTR.68    
                           DETA=ALEV(LGR)-Y(3)                               ZATTR.69    
                           R=DETA/(ALEV(LGR)-ALEV(LGR-1))                    ZATTR.70    
                           ZPART=ZPART+0.5*DETA                              ZATTR.71    
     :                          *((2.-R)*W2EARR(LGR)+R*W2EARR(LGR-1))        ZATTR.72    
                        ELSE                                                 ZATTR.73    
                           ZPART=W2EARR(LGR)*(BOUND-Y(3))                    ZATTR.74    
                        ENDIF                                                ZATTR.75    
                        POSN(NTIME,ILAB,3+IATTR)=ZPART                       ZATTR.76    
                     ELSE                                                    ZATTR.77    
                        CALL INTERP(FIELD,FP,M,J,L,P,Q,Y(3)                  SETATTR.144   
     :                       ,MP,JM,JHEM,JHEMM)                              SETATTR.145   
                        IF (IINTER.LT.NLOOP) THEN                            SETATTR.146   
                           CALL INTERP(OFIELD,FM,M,J,L,P,Q,Y(3)              SETATTR.147   
     :                          ,MP,JM,JHEM,JHEMM)                           SETATTR.148   
                        ENDIF                                                SETATTR.149   
                        POSN(NTIME,ILAB,3+IATTR)=S*FP+OMS*FM                 SETATTR.150   
                     ENDIF                                                   ZATTR.78    
                     ELSE                                                    SETATTR.151   
C                                                                            PSIATTR.14    
C     Single-level attribute fields.                                         PSIATTR.15    
C                                                                            PSIATTR.16    
                        POSN(NTIME,ILAB,3+IATTR)=S*FP+OMS*FM                 PSIATTR.17    
                     ENDIF                                                   SETATTR.153   
                  ENDIF                                                      SETATTR.154   
C                                                                            SETATTR.155   
C     Record pressure at particles position if required                      SETATTR.156   
C     for output in place of eta.                                            SETATTR.157   
C                                                                            SETATTR.158   
                  IF ((IATTR.EQ.1).AND.LPOUT) THEN                           SETATTR.159   
C                                                                            SETATTR.160   
C     Find LH such that:-                                                    SETATTR.161   
C     Values ascend with LH   ALEVH(LH) < Y(3) < ALEVH(LH+1).                SETATTR.162   
C                                                                            SETATTR.163   
                     LH=L                                                    SETATTR.164   
                     CALL HUNT(ALEVH,NL+1,Y(3),LH)                           SETATTR.165   
                     IF (LH.LT.1) LH=1                                       SETATTR.166   
                     IF (LH.GT.(NL-1)) LH=NL-1                               SETATTR.167   
                     PUP=AETA(LH+1)+BETA(LH+1)*PSP                           SETATTR.168   
                     PDOWN=AETA(LH)+BETA(LH)*PSP                             SETATTR.169   
                     PP=(PUP-PDOWN)*(Y(3)-ALEVH(LH))                         SETATTR.170   
     :                       /(ALEVH(LH+1)-ALEVH(LH))+PDOWN                  SETATTR.171   
                     IF (IINTER.LT.NLOOP) THEN                               SETATTR.172   
                        PUP=AETA(LH+1)+BETA(LH+1)*PSM                        SETATTR.173   
                        PDOWN=AETA(LH)+BETA(LH)*PSM                          SETATTR.174   
                        PM=(PUP-PDOWN)*(Y(3)-ALEVH(LH))                      SETATTR.175   
     :                       /(ALEVH(LH+1)-ALEVH(LH))+PDOWN                  SETATTR.176   
                     ENDIF                                                   SETATTR.177   
                     VPOSN(NTIME,ILAB)=S*PP+OMS*PM                           SETATTR.178   
                  ENDIF                                                      SETATTR.179   
                  S=S+DS                                                     SETATTR.180   
 910           CONTINUE                                                      SETATTR.181   
            ENDIF                                                            SETATTR.182   
 900     CONTINUE                                                            SETATTR.183   
 10   CONTINUE                                                               SETATTR.184   
C                                                                            SETATTR.185   
      RETURN                                                                 SETATTR.186   
      END                                                                    SETATTR.187   
C     ******************************************************************     SETATTR.188   
      SUBROUTINE READATTR(ICHAN,FIELD)                                       READATTR.2     
C                                                                            READATTR.3     
C     Read attribute from scratch file ICHAN.                                READATTR.4     
C                                                                            READATTR.5     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      INTEGER ICHAN                                                          READATTR.8     
      REAL ONELAT(IGD),FIELD(IGDLA)                                          READATTR.9     
C                                                                            READATTR.10    
      REWIND(ICHAN)                                                          READATTR.11    
      DO 10 J=1,JG                                                           READATTR.12    
         READ(ICHAN) ONELAT                                                  READATTR.13    
         DO 20 I=1,IGD                                                       READATTR.14    
            FIELD((J-1)*IGD+I)=ONELAT(I)                                     READATTR.15    
 20      CONTINUE                                                            READATTR.16    
 10   CONTINUE                                                               READATTR.17    
C                                                                            READATTR.18    
      RETURN                                                                 READATTR.19    
      END                                                                    READATTR.20    
C     ******************************************************************     READATTR.21    
      SUBROUTINE COPYATTR(ICHAN1,ICHAN2)                                     COPYATTR.2     
C                                                                            COPYATTR.3     
C     Copy attribute from scratch file ICHAN1 to ICHAN2.                     COPYATTR.4     
C                                                                            COPYATTR.5     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      INTEGER ICHAN1,ICHAN2                                                  COPYATTR.8     
      REAL ONELAT(IGD)                                                       COPYATTR.9     
C                                                                            COPYATTR.10    
      REWIND(ICHAN1)                                                         COPYATTR.11    
      REWIND(ICHAN2)                                                         COPYATTR.12    
      DO 10 J=1,JG                                                           COPYATTR.13    
         READ(ICHAN1) ONELAT                                                 COPYATTR.14    
         WRITE(ICHAN2) ONELAT                                                COPYATTR.15    
 10   CONTINUE                                                               COPYATTR.16    
C                                                                            COPYATTR.17    
      RETURN                                                                 COPYATTR.18    
      END                                                                    COPYATTR.19    
C     ****************************************************************       COPYATTR.20    
      SUBROUTINE INILAT                                                      INILAT.2     
C                                                                            INILAT.3     
C     Set latitudes.                                                         INILAT.4     
C     Subroutine GWTLT calculates Gaussian weights and latitudes.            INILAT.5     
C     If IUVFORMAT=1 must compile with the CRAY library                      INILAT.6     
C     /home/j90/kd/sgcm/sublib7.a .                                          INILAT.7     
C     Subroutine LEGDERV calculates Associated Legendre Functions (ALP)      INILAT.8     
C     and their derivatives (DALP) for the RS format.                        INILAT.9     
C                                                                            INILAT.10    
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/LEGAU/                                                          LEGAU.2     
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)       LEGAU.3     
     :,JH,JL                                                                 LEGAU.4     
C                                                                            LEGAU.5     
C                                                                            INILAT.17    
      DO 10 J=1,JG                                                           INILAT.18    
         JH=J                                                                INILAT.19    
         IF (IGRIDTYPE.EQ.0) THEN                                            INILAT.20    
            CALL GWTLT(SIJ,WEIGHT,J,JG,IWORDSIZE)                            INILAT.21    
            SI(J)=SIJ                                                        INILAT.22    
            ALAT(J)=ASIN(SIJ)                                                INILAT.23    
         ENDIF                                                               INILAT.24    
         IF (IGRIDTYPE.EQ.1) THEN                                            INILAT.25    
            ALAT(J)=.5*PI-J*.5*PI/FLOAT(JG+1)                                INILAT.26    
            SI(J)=SIN(ALAT(J))                                               INILAT.27    
         ENDIF                                                               INILAT.28    
         SISQ(J)=SI(J)*SI(J)                                                 INILAT.29    
         CSSQ(J)=1.-SISQ(J)                                                  INILAT.30    
         CS(J)=SQRT(CSSQ(J))                                                 INILAT.31    
         SECSQ(J)=1./CSSQ(J)                                                 INILAT.32    
         IF (IUVFORMAT.EQ.1) THEN                                            INILAT.33    
            GWT(J)=WEIGHT/FLOAT(NHEM)                                        INILAT.34    
            AW(J)=GWT(J)*FLOAT(NHEM)*2.*SECSQ(J)                             INILAT.35    
            CALL LEGDERV                                                     INILAT.36    
         ENDIF                                                               INILAT.37    
 10   CONTINUE                                                               INILAT.38    
      IF (NHEM.EQ.2) THEN                                                    INILAT.39    
         DO 40 J=1,JG                                                        INILAT.40    
            SI(JGGP-J)=-SI(J)                                                INILAT.41    
            CS(JGGP-J)=CS(J)                                                 INILAT.42    
            SISQ(JGGP-J)=SISQ(J)                                             INILAT.43    
            CSSQ(JGGP-J)=CSSQ(J)                                             INILAT.44    
            SECSQ(JGGP-J)=SECSQ(J)                                           INILAT.45    
            ALAT(JGGP-J)=-ALAT(J)                                            INILAT.46    
            IF (IUVFORMAT.EQ.1) THEN                                         INILAT.47    
               GWT(JGGP-J)=GWT(J)                                            INILAT.48    
               AW(JGGP-J)=AW(J)                                              INILAT.49    
            ENDIF                                                            INILAT.50    
 40      CONTINUE                                                            INILAT.51    
      ENDIF                                                                  INILAT.52    
C                                                                            INILAT.53    
      RETURN                                                                 INILAT.54    
      END                                                                    INILAT.55    
C     ****************************************************************       INILAT.56    
      SUBROUTINE INILEV                                                      INILEV.2     
C                                                                            INILEV.3     
C     Set up arrays detailing wind data levels and spacing.                  INILEV.4     
C                                                                            INILEV.5     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      IF (IUVFORMAT.NE.1) THEN                                               INILEV.9     
C                                                                            INILEV.10    
C     For vertical interpolation, set up a modified eta value at the         INILEV.11    
C     model half levels.  This uses P0 rather than PECMWF, to obtain         INILEV.12    
C     pressure levels in the range 0 < p < P0.                               INILEV.13    
C                                                                            INILEV.14    
         DO 10 L=1,NLM                                                       INILEV.15    
            SIGMAH(L)=AETA(L+1)+BETA(L+1)                                    INILEV.16    
 10      CONTINUE                                                            INILEV.17    
      ELSE                                                                   INILEV.18    
C                                                                            INILEV.19    
C     Set up sigma levels for vertical scheme.                               INILEV.20    
C     Equispaced for NL <= 5.                                                INILEV.21    
C     Set up half-levels.                                                    INILEV.22    
C                                                                            INILEV.23    
         STP=1./FLOAT(NL)                                                    INILEV.24    
         IF (NL.LE.5) THEN                                                   INILEV.25    
            DO 110 L=1,NLM                                                   INILEV.26    
               SIGMAH(L)=L*STP                                               INILEV.27    
 110        CONTINUE                                                         INILEV.28    
         ELSE                                                                INILEV.29    
            T1=(.9375/.94-1.25)/(.9375*(SQRT(.9375)-1.))                     INILEV.30    
            T2=4.+T1                                                         INILEV.31    
            P=0.                                                             INILEV.32    
            DO 120 L=1,NLM                                                   INILEV.33    
               P=P+STP                                                       INILEV.34    
               VV=P/(5.-T2*P+T1*(P**1.5))                                    INILEV.35    
               VV=VV*(2.-P)*(1.+.25*SIN(PI2*(P**.6)))                        INILEV.36    
               SIGMAH(L)=VV                                                  INILEV.37    
 120        CONTINUE                                                         INILEV.38    
         ENDIF                                                               INILEV.39    
         AETA(1)=0.                                                          INILEV.40    
         BETA(1)=0.                                                          INILEV.41    
         DO 130 L=1,NLM                                                      INILEV.42    
            AETA(L+1)=0.                                                     INILEV.43    
            BETA(L+1)=SIGMAH(L)                                              INILEV.44    
 130     CONTINUE                                                            INILEV.45    
         AETA(NL+1)=0.                                                       INILEV.46    
         BETA(NL+1)=1.                                                       INILEV.47    
      ENDIF                                                                  INILEV.48    
C                                                                            INILEV.49    
C     Calculate half-level functions.                                        INILEV.50    
C                                                                            INILEV.51    
      DO 310 L=1,NL                                                          INILEV.52    
         DBETA(L)=BETA(L+1)-BETA(L)                                          INILEV.53    
         CETA(L)=AETA(L+1)*BETA(L)-AETA(L)*BETA(L+1)                         INILEV.54    
 310  CONTINUE                                                               INILEV.55    
C                                                                            INILEV.56    
C     Derive remaining arrays used for vertical scheme.                      INILEV.57    
C     Nomenclature is from Reading model version, based on sigma             INILEV.58    
C     co-ords.  Arrays now contain equivalents for modified eta co-ord.      INILEV.59    
C                                                                            INILEV.60    
C     Calculate spacing between half-levels and set up full-levels.          INILEV.61    
C                                                                            INILEV.62    
      S1=0.                                                                  INILEV.63    
      DO 330 L=1,NLM                                                         INILEV.64    
         S2=SIGMAH(L)                                                        INILEV.65    
         DSIGMA(L)=S2-S1                                                     INILEV.66    
         SIGMA(L)=.5*(S2+S1)                                                 INILEV.67    
         S1=S2                                                               INILEV.68    
 330  CONTINUE                                                               INILEV.69    
      DSIGMA(NL)=1.-SIGMAH(NLM)                                              INILEV.70    
      SIGMA(NL)=.5*(1.+SIGMAH(NLM))                                          INILEV.71    
C                                                                            INILEV.72    
C     Set values used for sigma at model levels during                       INILEV.73    
C     interpolation.                                                         INILEV.74    
C                                                                            INILEV.75    
      DO 350 L=1,NL                                                          INILEV.76    
         ALEV(L)=SIGMA(L)                                                    INILEV.77    
 350  CONTINUE                                                               INILEV.78    
      ALEVH(1)=0.                                                            INILEV.79    
      DO 360 LH=1,NLM                                                        INILEV.80    
         ALEVH(LH+1)=SIGMAH(LH)                                              INILEV.81    
 360  CONTINUE                                                               INILEV.82    
      ALEVH(NL+1)=1.                                                         INILEV.83    
C                                                                            INILEV.84    
      RETURN                                                                 INILEV.85    
      END                                                                    INILEV.86    
C     ****************************************************************       INILEV.87    
      SUBROUTINE READREC                                                     READREC.2     
C                                                                            READREC.3     
C     Read history records and then calculate the wind field in              READREC.4     
C     grid point space for use in trajectory code.                           READREC.5     
C                                                                            READREC.6     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)                                       COMPSG.2     
C      PARAMETER(IGDLAP=1,IGCP=IGC)                                          COMPSG.3     
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)             COMPSG.4     
     :,BLETAM(IGCP,JG)                                                       SFCDATA.14    
C                                                                            COMPSG.5     
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/LEGAU/                                                          LEGAU.2     
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)       LEGAU.3     
     :,JH,JL                                                                 LEGAU.4     
C                                                                            LEGAU.5     
      REAL CHI(IGD)                                                          READREC.15    
C                                                                            BUGS3EC.54    
C     Rewind attribute scratch files.                                        BUGS3EC.55    
C                                                                            BUGS3EC.56    
      DO 10 ICHAN=1,MAXATTR                                                  BUGS3EC.57    
         REWIND(NCGP(ICHAN))                                                 BUGS3EC.58    
   10 CONTINUE                                                               BUGS3EC.59    
C                                                                            READREC.16    
C     Read spectral coefficients from GRIB spectral file.                    READREC.17    
C     Read grid point specific humidity if necessary.                        READREC.18    
C                                                                            READREC.19    
      IF (IUVFORMAT.EQ.0) THEN                                               READREC.20    
	 IF (IGRIBV.EQ.1) THEN                                                      SFCDATA.307   
            CALL GSCOEFFS		                                                  SFCDATA.308   
            IF (LQATTR.AND.LGPQ) CALL GPQREAD                                SFCDATA.309   
            IF (LSFCATTR) CALL READSFC                                       SFCDATA.310   
         ELSE                                                                SFCDATA.311   
            CALL GSCOEFFS2		                                                 SFCDATA.312   
            IF (LQATTR.AND.LGPQ) CALL GPQREAD2                               SFCDATA.313   
            IF (LSFCATTR) CALL READSFC2                                      SFCDATA.314   
         ENDIF                                                               SFCDATA.315   
      ENDIF                                                                  READREC.23    
C                                                                            READREC.24    
C     Read spectral coefficients from RSGCM history file.                    READREC.25    
C                                                                            READREC.26    
      IF (IUVFORMAT.EQ.1) CALL RSCOEFFS                                      READREC.27    
C                                                                            READREC.34    
C     Loop over latitude for spectral to grid transform                      READREC.35    
C     and grid point calculations.                                           READREC.36    
C                                                                            READREC.37    
      JL=1                                                                   READREC.38    
      DO 100 IH=1,JG                                                         READREC.39    
C                                                                            READREC.40    
C     Spectral to grid transform and preliminary                             READREC.41    
C     grid point calculations for GRIB winds.                                READREC.42    
C                                                                            READREC.43    
         IF (IUVFORMAT.EQ.0) CALL GSP2GRID                                   READREC.44    
C                                                                            READREC.45    
C     Spectral to grid transform and preliminary                             READREC.46    
C     grid point calculations for RSGCM winds.                               READREC.47    
C                                                                            READREC.48    
         IF (IUVFORMAT.EQ.1) CALL RSP2GRID                                   READREC.49    
C                                                                            READREC.50    
C     Calculate pressure on half and full eta-levels.                        READREC.51    
C     NOTE: PLG contains surface pressure by this stage.                     READREC.52    
C                                                                            READREC.53    
         DO 320 I=1,IGC                                                      READREC.54    
            PLGLA(I,JL)=PLG(I)                                               READREC.55    
 320     CONTINUE                                                            READREC.56    
         DO 330 L=1,NL+1                                                     READREC.57    
            DO 340 II=1,IGC                                                  READREC.58    
               PSGH(II,L)=AETA(L)+BETA(L)*PLG(II)                            READREC.59    
 340        CONTINUE                                                         READREC.60    
 330     CONTINUE                                                            READREC.61    
         DO 350 L=1,NL                                                       READREC.62    
            DO 360 II=1,IGC                                                  READREC.63    
               PSG(II,L)=.5*(PSGH(II,L)+PSGH(II,L+1))                        READREC.64    
 360        CONTINUE                                                         READREC.65    
 350     CONTINUE                                                            READREC.66    
C                                                                            READREC.67    
C     Vertical velocity calculation.                                         READREC.68    
C                                                                            READREC.69    
         CALL ETADOT                                                         READREC.70    
         CALL DENSCALC                                                       ZATTR.79    
C                                                                            READREC.71    
C     Calculate Ertel PV.                                                    READREC.72    
C                                                                            READREC.73    
         IF (LPVATTR) CALL PVCR                                              READREC.74    
         IF (LSFCATTR) CALL ETABLCALC                                        SFCDATA.316   
C         IF (LPVATTR) CALL ETATPPCALC                                       SFCDATA.317   
C                                                                            READREC.75    
C     Grid point calculations for the functions of the wind field            READREC.76    
C     which equal the Lagrangian tendencies for longitude, latitude          READREC.77    
C     and eta/pressure (depending upon IUVFORMAT).                           READREC.78    
C     The WW factor arises from dimensionalising the wind fields.            READREC.79    
C                                                                            READREC.80    
         KK=(JL-1)*IGD                                                       READREC.81    
         IF (LFORW) THEN                                                     READREC.82    
            DO 400 I=1,IGD                                                   READREC.83    
               URHS(KK+I)=UG(I)*WW*86400.*SECSQ(IH)                          READREC.84    
               VRHS(KK+I)=VG(I)*WW*86400./CS(IH)                             READREC.85    
               SDRHS(KK+I)=SDOTG(I)*WW*86400.                                READREC.86    
 400        CONTINUE                                                         READREC.87    
         ELSE                                                                READREC.88    
            DO 410 I=1,IGD                                                   READREC.89    
               URHS(KK+I)=-UG(I)*WW*86400.*SECSQ(IH)                         READREC.90    
               VRHS(KK+I)=-VG(I)*WW*86400./CS(IH)                            READREC.91    
               SDRHS(KK+I)=-SDOTG(I)*WW*86400.                               READREC.92    
 410        CONTINUE                                                         READREC.93    
         ENDIF                                                               READREC.94    
C                                                                            READREC.95    
C     Write single latitude grid point arrays to scratch files               READREC.96    
C     for the attributes.                                                    READREC.97    
C                                                                            READREC.98    
C     Store temperature and potential temperature.                           READREC.99    
C                                                                            READREC.100   
         IF (LTATTR) THEN                                                    READREC.101   
            DO 420 L=1,NL                                                    READREC.102   
               LL=(L-1)*IGC                                                  READREC.103   
               DO 425 I=1,IGC                                                READREC.104   
                  PMKG=PSG(I,L)**(-AKAP)                                     READREC.105   
                  TG(LL+I)=TG(LL+I)*CT                                       READREC.106   
                  THG(LL+I)=TG(LL+I)*PMKG                                    READREC.107   
                  THGLA(KK+LL+I)=THG(LL+I)                                   READREC.108   
 425           CONTINUE                                                      READREC.109   
 420        CONTINUE                                                         READREC.110   
            WRITE(NCGP(1)) TG                                                READREC.111   
            WRITE(NCGP(2)) THG                                               READREC.112   
         ENDIF                                                               READREC.113   
C                                                                            READREC.114   
C     Store Ertel PV.                                                        READREC.115   
C                                                                            READREC.116   
         IF (LPVATTR) THEN                                                   READREC.117   
            DO 430 I=1,IGD                                                   READREC.118   
               EPVG(I)=EPVG(I)*CERT                                          READREC.119   
 430        CONTINUE                                                         READREC.120   
            WRITE(NCGP(3)) EPVG                                              READREC.121   
         ENDIF                                                               READREC.122   
C                                                                            READREC.123   
C     Store specific humidity.                                               READREC.124   
C                                                                            READREC.125   
         IF (LQATTR.AND.(.NOT.LGPQ)) THEN                                    READREC.126   
            DO 440 I=1,IGD                                                   READREC.127   
               QG(I)=QG(I)*CQ                                                READREC.128   
 440        CONTINUE                                                         READREC.129   
            WRITE(NCGP(4)) QG                                                READREC.130   
         ENDIF                                                               READREC.131   
C                                                                            READREC.132   
C     Store tracer fields.                                                   READREC.133   
C                                                                            READREC.134   
         IF (LTRACSWITCH) THEN                                               READREC.135   
            IF (NCHI(1).LE.NTRAC) THEN                                       READREC.136   
               KTRA=(NCHI(1)-1)*IGD                                          READREC.137   
               DO 450 I=1,IGD                                                READREC.138   
                  CHI(I)=TRAG(KTRA+I)*CTRA(NCHI(1))                          READREC.139   
 450           CONTINUE                                                      READREC.140   
               WRITE(NCGP(5)) CHI                                            READREC.141   
            ENDIF                                                            READREC.142   
            IF (NCHI(2).LE.NTRAC) THEN                                       READREC.143   
               KTRA=(NCHI(2)-1)*IGD                                          READREC.144   
               DO 460 I=1,IGD                                                READREC.145   
                  CHI(I)=TRAG(KTRA+I)*CTRA(NCHI(2))                          READREC.146   
 460           CONTINUE                                                      READREC.147   
               WRITE(NCGP(6)) CHI                                            READREC.148   
            ENDIF                                                            READREC.149   
         ENDIF                                                               READREC.150   
C                                                                            READREC.151   
         JL=JL+1                                                             READREC.152   
 100  CONTINUE                                                               READREC.153   
C                                                                            READREC.154   
      RETURN                                                                 READREC.155   
      END                                                                    READREC.156   
C     *****************************************************************      READREC.157   
      SUBROUTINE ETADOT                                                      ETADOT.2     
C                                                                            ETADOT.3     
C     Calculate etadot (vertical velocity in eta-coords) on                  ETADOT.4     
C     half-levels.                                                           ETADOT.5     
C     UGCM: hybrid sigma/pressure co-ordinate.                               ETADOT.6     
C     Follows ECMWF Research Manual 2, section 2.2.2.                        ETADOT.7     
C                                                                            ETADOT.8     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/LEGAU/                                                          LEGAU.2     
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)       LEGAU.3     
     :,JH,JL                                                                 LEGAU.4     
C                                                                            LEGAU.5     
      REAL OMSRF(IGC),VGP,GVDP,DETADP                                        ETADOT.14    
C                                                                            ETADOT.15    
C     Preset etadot grid array.                                              ETADOT.16    
C                                                                            ETADOT.17    
      DO 10 I=1,IGD                                                          ETADOT.18    
         SDOTG(I)=0.                                                         ETADOT.19    
   10 CONTINUE                                                               ETADOT.20    
C                                                                            ETADOT.21    
C     Main loop over latitude pair.                                          ETADOT.22    
C                                                                            ETADOT.23    
      DO 100 IHEM=1,NHEM                                                     ETADOT.24    
         IOF=(IHEM-1)*MGPP                                                   ETADOT.25    
C                                                                            ETADOT.26    
C     Preset surface pressure tendency.                                      ETADOT.27    
C                                                                            ETADOT.28    
         DO 20 I=1,MG                                                        ETADOT.29    
            II=I+IOF                                                         ETADOT.30    
            OMSRF(II)=0.                                                     ETADOT.31    
 20      CONTINUE                                                            ETADOT.32    
C                                                                            ETADOT.33    
C     Surface omega (surface pressure tendency) from                         ETADOT.34    
C     integral of continuity equation.                                       ETADOT.35    
C                                                                            ETADOT.36    
         DO 30 L=1,NLM                                                       ETADOT.37    
            KK=(L-1)*IGC                                                     ETADOT.38    
            DO 40 I=1,MG                                                     ETADOT.39    
               II=I+IOF                                                      ETADOT.40    
               K=KK+II                                                       ETADOT.41    
               VGP=SECSQ(JL)*(UG(K)*PMG(II)+VG(K)*PJG(II))                   ETADOT.42    
               GVDP=DG(K)*(PSGH(II,L+1)-PSGH(II,L))                          ETADOT.43    
     ;              +PLG(II)*DBETA(L)*VGP                                    ETADOT.44    
               OMSRF(II)=OMSRF(II)-GVDP                                      ETADOT.45    
               SDOTG(K)=OMSRF(II)                                            ETADOT.46    
 40         CONTINUE                                                         ETADOT.47    
 30      CONTINUE                                                            ETADOT.48    
         KK=(NL-1)*IGC                                                       ETADOT.49    
         DO 50 I=1,MG                                                        ETADOT.50    
            II=I+IOF                                                         ETADOT.51    
            K=KK+II                                                          ETADOT.52    
            VGP=SECSQ(JL)*(UG(K)*PMG(II)+VG(K)*PJG(II))                      ETADOT.53    
            GVDP=DG(K)*(PSGH(II,NL+1)-PSGH(II,NL))                           ETADOT.54    
     ;           +PLG(II)*DBETA(NL)*VGP                                      ETADOT.55    
            OMSRF(II)=OMSRF(II)-GVDP                                         ETADOT.56    
 50      CONTINUE                                                            ETADOT.57    
C                                                                            ETADOT.58    
C     Combine surface pressure tendency and integral in SDOTG.               ETADOT.59    
C                                                                            ETADOT.60    
         DO 90 L=1,NLM                                                       ETADOT.61    
            KK=(L-1)*IGC                                                     ETADOT.62    
            DO 80 I=1,MG                                                     ETADOT.63    
               II=I+IOF                                                      ETADOT.64    
               K=KK+II                                                       ETADOT.65    
               DETADP=(ALEVH(L+2)-ALEVH(L))/(PSGH(II,L+2)-PSGH(II,L))        ETADOT.66    
               SDOTG(K)=DETADP*( -BETA(L+1)*OMSRF(II)+SDOTG(K) )             ETADOT.67    
 80         CONTINUE                                                         ETADOT.68    
 90      CONTINUE                                                            ETADOT.69    
 100  CONTINUE                                                               ETADOT.70    
C                                                                            ETADOT.71    
      RETURN                                                                 ETADOT.72    
      END                                                                    ETADOT.73    
C     *****************************************************************      ETADOT.74    
      SUBROUTINE PVCR                                                        PVCR.2     
C                                                                            PVCR.3     
C     Calculate Ertel potential vorticity on model levels.                   PVCR.4     
C     For hybrid pressure-sigma vertical co-ordinate.                        PVCR.5     
C                                                                            PVCR.6     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/COMGRM/DUDLSG(IGC,NL),DVDLSG(IGC,NL),DTDLSG(IGC,NL)             COMGRM.2     
C                                                                            COMGRM.3     
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/LEGAU/                                                          LEGAU.2     
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)       LEGAU.3     
     :,JH,JL                                                                 LEGAU.4     
C                                                                            LEGAU.5     
      REAL ECDP(NL),ECB(NL)                                                  PVCR.13    
C                                                                            PVCR.14    
      CALL DLSGCR(IGC,UG,RGG,DUDLSG,IGC,NL)                                  PVCR.15    
      CALL DLSGCR(IGC,VG,RGG,DVDLSG,IGC,NL)                                  PVCR.16    
      CALL DLSGCR(IGC,TG,RGG,DTDLSG,IGC,NL)                                  PVCR.17    
      DO 100 IHEM=1,NHEM                                                     PVCR.18    
         IOF=(IHEM-1)*MGPP                                                   PVCR.19    
C                                                                            PVCR.20    
C     Calculate PV on model levels.                                          PVCR.21    
C     Generalised formula using array of model level pressures.              PVCR.22    
C     Note that the reference pressure for adiabatic processes is            PVCR.23    
C     assumed to be P0, the non-dimensionalising pressure.                   PVCR.24    
C                                                                            PVCR.25    
         DO 10 I=1,MG                                                        PVCR.26    
            II=I+IOF                                                         PVCR.27    
            ECDP(1)=PSGH(II,2)-PSGH(II,1)                                    PVCR.28    
            ECB(1)=0.                                                        PVCR.29    
            DO 2 L=2,NL                                                      PVCR.30    
               ECDP(L)=PSGH(II,L+1)-PSGH(II,L)                               PVCR.31    
               ECB(L)=ALOG(PSGH(II,L+1)/PSGH(II,L))                          PVCR.32    
 2          CONTINUE                                                         PVCR.33    
            DO 4 L=1,NL                                                      PVCR.34    
               K=(L-1)*IGC+II                                                PVCR.35    
               PMKG=PSG(II,L)**(-AKAP)                                       PVCR.36    
               GPFAC=(DBETA(L)+CETA(L)*ECB(L)/ECDP(L))*PLG(II)/ECDP(L)       PVCR.37    
               EDPDE=SIGMA(L)*ECDP(L)/DSIGMA(L)                              PVCR.38    
               PFACT=PMKG/EDPDE                                              PVCR.39    
               AKT=AKAP*TG(K)                                                PVCR.40    
               TXP=TXG(K)-AKT*GPFAC*PMG(II)                                  PVCR.41    
               TYP=TYG(K)-AKT*GPFAC*PJG(II)                                  PVCR.42    
               EPVG(K)=PFACT*(ZG(K)*(-DTDLSG(II,L)+AKT*EDPDE/PSG(II,L))      PVCR.43    
     :              +SECSQ(JH)*(-DUDLSG(II,L)*TYP+DVDLSG(II,L)*TXP))         PVCR.44    
 4          CONTINUE                                                         PVCR.45    
 10      CONTINUE                                                            PVCR.46    
C                                                                            PVCR.47    
 100  CONTINUE                                                               PVCR.48    
C                                                                            PVCR.49    
      RETURN                                                                 PVCR.50    
      END                                                                    PVCR.51    
C     *****************************************************************      PVCR.52    
      SUBROUTINE DLSGCR(NCOL,F,RGG,DF,IDIM,NL)                               DLSGCR.2     
C                                                                            DLSGCR.3     
C     Black-box routine to take vertical derivative of a 2D array            DLSGCR.4     
C     in the model's vertical co-ordinates using the RGG matrix:             DLSGCR.5     
C                                                                            DLSGCR.6     
C              DF   =   RGG   *   F                                          DLSGCR.7     
C                                                                            DLSGCR.8     
C     gives    DF   =   d(F)/dln(sigma)   =   (sigma)d(F)/d(sigma).          DLSGCR.9     
C                                                                            DLSGCR.10    
C     Calculates DF at NL levels for NCOL columns from the array F.          DLSGCR.11    
C     Uses vector loops over NCOL at each level.  Note that for              DLSGCR.12    
C     NCOL <= 3 inner loops unroll to give vectorisation over levels.        DLSGCR.13    
C                                                                            DLSGCR.14    
C     Uses explicit values of RGG matrix rather than function SDOT           DLSGCR.15    
C     over NL elements of RGG at each level.  Due to sparse nature           DLSGCR.16    
C     of RGG, this gives large speed-up for NL >> 3.                         DLSGCR.17    
C                                                                            DLSGCR.18    
C     Reading model - sigma.                                                 DLSGCR.19    
C                                                                            DLSGCR.20    
      REAL F(IDIM,NL),DF(IDIM,NL),RGG(NL,NL)                                 DLSGCR.21    
C                                                                            DLSGCR.22    
 6900 FORMAT(/' ***ABORT IN DLSGCR: MORE COLUMNS THAN ARRAY DIMENSION:'      DLSGCR.23    
     :       ,' NCOL IDIM =',2I10)                                           DLSGCR.24    
C                                                                            DLSGCR.25    
      IF (NCOL.GT.IDIM) THEN                                                 DLSGCR.26    
         WRITE(2,6900) NCOL,IDIM                                             DLSGCR.27    
         CALL ABORT                                                          DLSGCR.28    
      ENDIF                                                                  DLSGCR.29    
C                                                                            DLSGCR.30    
      NLM=NL-1                                                               DLSGCR.31    
      NLMM=NL-2                                                              DLSGCR.32    
C     Top and bottom levels.                                                 DLSGCR.33    
      DO 10 I=1,NCOL                                                         DLSGCR.34    
      DF(I,1 )=F(I,1)*RGG(1,1)+F(I,2)*RGG(2,1)+F(I,3)*RGG(3,1)               DLSGCR.35    
      DF(I,NL)=F(I,NLMM)*RGG(NLMM,NL)+F(I,NLM)*RGG(NLM,NL)                   DLSGCR.36    
     :        +F(I,NL)*RGG(NL,NL)                                            DLSGCR.37    
   10 CONTINUE                                                               DLSGCR.38    
C     Intermediate levels.                                                   DLSGCR.39    
      DO 20 L=2,NLM                                                          DLSGCR.40    
      DO 20 I=1,NCOL                                                         DLSGCR.41    
      DF(I,L)=F(I,L-1)*RGG(L-1,L)+F(I,L+1)*RGG(L+1,L)                        DLSGCR.42    
   20 CONTINUE                                                               DLSGCR.43    
C                                                                            DLSGCR.44    
      RETURN                                                                 DLSGCR.45    
      END                                                                    DLSGCR.46    
C     *******************************************************                DLSGCR.47    
      SUBROUTINE MAKENAME(FSTEM,IOFFSET,INPFNAME,NCDATE,LGPQ)                MAKENAME.2     
C                                                                            MAKENAME.3     
C     Determine filename for next record.                                    MAKENAME.4     
C                                                                            MAKENAME.5     
C     Calls: IDATXC, CDXDAT - taken from Package X by Roger Brugge.          MAKENAME.6     
C     Calls: IDATXC2000, CDXDAT2000 - handle any date > 1/1/1900.            Y2K.18    
C                                                                            MAKENAME.7     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
      INTEGER NEWCD,KY,KM,KD,KH,NCDATE                                       MAKENAME.11    
     :       ,IPOSTSP,ISTERA,IENDERA                                         MAKENAME.12    
      REAL STCD,RNEWCD                                                       MAKENAME.13    
      LOGICAL LGPQ                                                           MAKENAME.14    
      CHARACTER*80 FSTEM,INPFNAME                                            MAKENAME.15    
C                                                                            MAKENAME.16    
C     Find century days for start date and latest time.                      MAKENAME.17    
C                                                                            MAKENAME.18    
      IF (ISYY.GT.99) THEN                                                   Y2K.19    
         STCD=FLOAT(IDATXC2000(ISDD,ISMM,ISYY))+FLOAT(ISHH)/24.              Y2K.20    
      ELSE                                                                   Y2K.21    
         STCD=FLOAT(IDATXC(ISDD,ISMM,ISYY))+FLOAT(ISHH)/24.                  Y2K.22    
      ENDIF                                                                  Y2K.23    
      TIMEINT=DAY-BEGDAY                                                     MAKENAME.20    
      IF (.NOT.LFORW) TIMEINT=-TIMEINT                                       MAKENAME.21    
      RNEWCD=STCD+TIMEINT                                                    MAKENAME.22    
      NEWCD=INT(RNEWCD+.00001)                                               MAKENAME.23    
C                                                                            MAKENAME.24    
C     Convert back to YYMMDDHH.                                              MAKENAME.25    
C                                                                            MAKENAME.26    
      KH=NINT(24.*(RNEWCD-FLOAT(NEWCD)))                                     MAKENAME.27    
      IF (ISYY.GT.99) THEN                                                   Y2K.24    
         CALL CDXDAT2000(NEWCD,KD,KM,KY)                                     Y2K.25    
      ELSE                                                                   Y2K.26    
         CALL CDXDAT(NEWCD,KD,KM,KY)                                         Y2K.27    
         KY=MOD(KY,100)                                                      Y2K.28    
      ENDIF                                                                  Y2K.29    
      NCDATE=KY*1000000+KM*10000+KD*100+KH                                   MAKENAME.30    
      KYY=KY                                                                 SFCDATA.318   
      KMM=KM                                                                 SFCDATA.319   
      KDD=KD                                                                 SFCDATA.320   
      KHH=KH                                                                 SFCDATA.321   
C                                                                            MAKENAME.31    
C     Make filename for next record.                                         MAKENAME.32    
C                                                                            MAKENAME.33    
      INPFNAME=FSTEM                                                         MAKENAME.34    
      IF (ISYY.GT.99) THEN                                                   Y2K.30    
         IF (LYRNAM) THEN                                                    Y2K.31    
            WRITE(INPFNAME(IOFFSET:IOFFSET+14),'(I4,A1,I10)')                Y2K.32    
     :           ISYY,'/',NCDATE                                             Y2K.33    
         ELSE                                                                Y2K.34    
            WRITE(INPFNAME(IOFFSET:IOFFSET+9),'(I10)') NCDATE                Y2K.35    
         ENDIF                                                               Y2K.36    
         LGPQ=.TRUE.                                                         Y2K.37    
      ELSE                                                                   Y2K.38    
         WRITE(INPFNAME(IOFFSET:IOFFSET+7),'(I8)') NCDATE                    Y2K.39    
C                                                                            MAKENAME.40    
C     Test for type of specific humidity data based on dates.                MAKENAME.41    
C                                                                            MAKENAME.42    
      IPOSTSP=IDATXC(04,04,95)                                               MAKENAME.43    
      ISTERA=IDATXC(01,01,79)                                                MAKENAME.44    
      IENDERA=IDATXC(28,02,94)                                               MAKENAME.45    
      LGPQ=.FALSE.                                                           MAKENAME.46    
      IF (NEWCD.GE.IPOSTSP) THEN                                             MAKENAME.47    
         LGPQ=.TRUE.                                                         MAKENAME.48    
      ELSE                                                                   MAKENAME.49    
         IF (LERA.AND.(NEWCD.GE.ISTERA).AND.(NEWCD.LE.IENDERA)) THEN         MAKENAME.50    
            LGPQ=.TRUE.                                                      MAKENAME.51    
         ENDIF                                                               MAKENAME.52    
      ENDIF                                                                  MAKENAME.53    
      ENDIF                                                                  Y2K.40    
C                                                                            MAKENAME.54    
      RETURN                                                                 MAKENAME.55    
      END                                                                    MAKENAME.56    
C     **************************************************************         MAKENAME.57    
      SUBROUTINE INIGS                                                       INIGS.2     
C                                                                            INIGS.3     
C     Set up for GRIB spectral history data (from ECMWF).                    INIGS.4     
C                                                                            INIGS.5     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
      COMMON/COMFFT/NTWG,NRSTWG,TRIG(IDA),WORK(IDF),IFAX(10)                 COMFFT.2     
C                                                                            COMFFT.3     
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/POLYNO/POLYF(NWJ2,NHEM),CMPA(IGL)                               POLYNO.2     
      COMPLEX CMPA                                                           POLYNO.3     
C                                                                            POLYNO.4     
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM           PARAMX.2     
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)                             PARAMX.3     
C                                                                            PARAMX.4     
      PARAMETER(JLATS=2*(JG+1)+1,ILEN4=MG*JLATS)                             Y2K.42    
      INTEGER IREC,IREM,INPFEND,IFIELD,KLEV,ISTAT                            Y2K.43    
      DIMENSION SPARR(JPFLSH),ZSEC4(ILEN4)                                   Y2K.44    
C                                                                            INIGS.14    
 6110 FORMAT(/' LATITUDES (DEGREES)'/(15F7.3))                               INIGS.15    
 6120 FORMAT(/' SIGMA AT HALF LEVELS'/(15F7.4))                              INIGS.16    
 6130 FORMAT(/' SIGMA AT FULL LEVELS'/(15F7.4))                              INIGS.17    
 6140 FORMAT(/' PRESSURE AT DATA LEVELS'/(15F7.4))                           INIGS.18    
C                                                                            Y2K.45    
C     Determine channel for required GRIB spectral file.                     Y2K.46    
C     Find filename for channel.                                             Y2K.47    
C                                                                            Y2K.48    
      IREC=NINT((DAY-BEGDAY)/THIST)                                          Y2K.49    
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)                                   Y2K.50    
      INPFEND=IOFFSET+7                                                      Y2K.51    
      IF (ISYY.GT.99) INPFEND=IOFFSET+9                                      Y2K.52    
      IF (IREM.EQ.0) THEN                                                    Y2K.53    
         CALL MAKENAME(FSTEM,IOFFSET,INPFNAME,NCDATE,LGPQ)                   Y2K.54    
         WRITE(LOUTP,*) 'Assuming file ',INPFNAME(1:INPFEND)                 Y2K.55    
     :        ,' is Cray unblocked'                                          Y2K.56    
         ISTAT=0                                                             Y2K.57    
C                                                                            Y2K.58    
C     Note that PBOPEN will change the channel number INPUT.                 Y2K.59    
C                                                                            Y2K.60    
         CALL PBOPEN(INPUT,INPFNAME(1:INPFEND),'r',ISTAT)                    Y2K.61    
         IF(ISTAT.NE.0) THEN                                                 Y2K.62    
            WRITE(LOUTP,*) 'Error opening file ',INPFNAME(1:INPFEND)         Y2K.63    
            WRITE(LOUTP,*) 'PBOPEN returns ISTAT = ',ISTAT                   Y2K.64    
            WRITE(LOUTP,*) 'Called from INIGS'                               Y2K.65    
            CALL ABORT                                                       Y2K.66    
         ELSE                                                                Y2K.67    
            PRINT *,INPFNAME(1:INPFEND),' OPENED'                            Y2K.68    
         ENDIF                                                               Y2K.69    
      ENDIF                                                                  Y2K.70    
C                                                                            INIGS.40    
C     Set up levels for vertical scheme.                                     INIGS.41    
C                                                                            INIGS.42    
      IF (ILEVTYPE.EQ.0) THEN                                                INIGS.43    
C                                                                            Y2K.71    
C     ECMWF eta-levels (GRIB level code 109).                                Y2K.72    
C                                                                            Y2K.73    
         IFIELD=-1                                                           Y2K.74    
         CALL SPUNPACK(SPARR,JPFLSH,INPUT,IFIELD,KLEV)                       Y2K.75    
         CALL INILEV                                                         INIGS.53    
         WRITE(LOUTP,6120) SIGMAH                                            INIGS.54    
         WRITE(LOUTP,6130) SIGMA                                             INIGS.55    
      ENDIF                                                                  INIGS.56    
      IF (ILEVTYPE.EQ.1) THEN                                                INIGS.57    
C                                                                            Y2K.76    
C     Standard pressure levels (GRIB level code 100).                        Y2K.77    
C                                                                            Y2K.78    
C     Loop over variables Z,T,U,V,Q,W for all levels.                        Y2K.79    
C     NOTE: these records contain relative humidity.                         Y2K.80    
C                                                                            Y2K.81    
         IFIELD=0                                                            Y2K.82    
         DO 100 L=1,NL                                                       Y2K.83    
            DO 105 IVAR=1,6                                                  Y2K.84    
               CALL SPUNPACK(ZSEC4,ILEN4,INPUT,IFIELD,KLEV)                  Y2K.85    
 105        CONTINUE                                                         Y2K.86    
            ALEV(L)=FLOAT(KLEV)/1000.                                        Y2K.87    
            SIGMA(L)=ALEV(L)                                                 Y2K.88    
 100     CONTINUE                                                            Y2K.89    
         ALEVH(1)=0.                                                         INIGS.75    
         ALEVH(NL+1)=0.                                                      INIGS.76    
         DO 110 L=1,NLM                                                      INIGS.77    
            ALEVH(L+1)=0.                                                    INIGS.78    
            SIGMAH(L)=0.                                                     INIGS.79    
 110     CONTINUE                                                            INIGS.80    
         WRITE(LOUTP,6140) SIGMA                                             INIGS.81    
      ENDIF                                                                  INIGS.82    
C                                                                            Y2K.90    
C     Close input file.                                                      Y2K.91    
C                                                                            Y2K.92    
      IF (IREM.EQ.0) THEN                                                    Y2K.93    
         ISTAT=0                                                             Y2K.94    
         CALL PBCLOSE(INPUT,ISTAT)                                           Y2K.95    
         IF(ISTAT.NE.0) THEN                                                 Y2K.96    
            WRITE(LOUTP,*) 'ERROR CLOSING FILE ',INPFNAME(1:INPFEND)         Y2K.97    
            WRITE(LOUTP,*) 'ISTAT = ',ISTAT                                  Y2K.98    
            CALL ABORT                                                       Y2K.99    
         ENDIF                                                               Y2K.100   
      ENDIF                                                                  Y2K.101   
C                                                                            INIGS.83    
C     Derive spectral constants from resolution parameters.                  INIGS.84    
C                                                                            INIGS.85    
      MF=MM-1                                                                INIGS.86    
      MFP=MM                                                                 INIGS.87    
      MFPP=MM+1                                                              INIGS.88    
      NF=NN-1                                                                INIGS.89    
      NFP=NN                                                                 INIGS.90    
      NFPP=NN+1                                                              INIGS.91    
C                                                                            INIGS.92    
C     Spectral arrays for Legendre transforms.                               INIGS.93    
C                                                                            INIGS.94    
      SQ(1)=0.                                                               INIGS.95    
      RSQ(1)=0.                                                              INIGS.96    
      DO 12 NP=2,NN+2                                                        INIGS.97    
         SQ(NP)=NP*(NP-1)                                                    INIGS.98    
         RSQ(NP)=1./SQ(NP)                                                   INIGS.99    
 12   CONTINUE                                                               INIGS.100   
C                                                                            INIGS.101   
C     Set up latitudes.                                                      INIGS.102   
C     If winds are on a Gaussian grid set up                                 INIGS.103   
C     Legendre functions also.                                               INIGS.104   
C                                                                            INIGS.105   
      CALL INILAT                                                            INIGS.106   
      WRITE(LOUTP,6110) (ALAT(J)*180./PI,J=JG,1,-1)                          INIGS.107   
C                                                                            INIGS.108   
C     Array to calculate x-derivatives of Fourier coefficients.              INIGS.109   
C                                                                            INIGS.110   
      DO 20 I=1,IGL                                                          INIGS.111   
  20  CMPA(I)=0.                                                             INIGS.112   
      NROW=0                                                                 INIGS.113   
      DO 30 MP=1,MFP,MOCT                                                    INIGS.114   
      NROW=NROW+1                                                            INIGS.115   
      CMPA(NROW)=CMPLX(0.,FLOAT(MP-1))                                       INIGS.116   
      IF (NHEM.EQ.2) CMPA(NROW+IDL)=CMPA(NROW)                               INIGS.117   
  30  CONTINUE                                                               INIGS.118   
C                                                                            INIGS.119   
C     Normalisation for m=0,n=1 coefficient used to obtain                   INIGS.120   
C     planetary vorticity.                                                   INIGS.121   
C                                                                            INIGS.122   
      EZR=1./SQRT(.75)                                                       INIGS.123   
C                                                                            INIGS.124   
C     Set up variables used for FFT99.                                       INIGS.125   
C                                                                            INIGS.126   
      CALL SET99(TRIG,IFAX,MG)                                               FFTCHANGE.1     
C                                                                            INIGS.130   
C     Assume that ECMWF records contain specific humidity.                   INIGS.131   
C                                                                            INIGS.132   
      LDRY=.FALSE.                                                           INIGS.133   
      LGPQ=.FALSE.                                                           INIGS.134   
C                                                                            INIGS.135   
      RETURN                                                                 INIGS.136   
      END                                                                    INIGS.137   
C     ***************************************************************        INIGS.138   
C                                                                            GWTLT.2     
C     Calculates the Gaussian latitudes and weights.                         GWTLT.3     
C                                                                            GWTLT.4     
C     Copy of the library version in ~kd/sgcm/sublib7.npl in order           GWTLT.5     
C     to avoid the library call.                                             GWTLT.6     
C                                                                            GWTLT.7     
      SUBROUTINE GWTLT(SIT,WEIGHT,J,JG,IWORDSIZE)                            GWTLT.8     
C                                                                            GWTLT.9     
      PARAMETER(PI=3.14159265359)                                            GWTLT.10    
      DOUBLE PRECISION ACC,SA,SB,SC,D1,D2,D4,BN,GG,X,AMM,AMN,                GWTLT.11    
     1 EM,ANN,RE,A,DD,DLT,DTH                                                GWTLT.12    
C                                                                            GWTLT.13    
C     For 64-bit, double precision arithmetic ACC=1.0D-23.                   GWTLT.14    
C     For 32-bit, double precision arithmetic ACC=1.0D-16.                   GWTLT.15    
C                                                                            GWTLT.16    
      IF (IWORDSIZE.EQ.8) THEN                                               GWTLT.17    
         ACC=1.0D-23                                                         GWTLT.18    
      ELSE                                                                   GWTLT.19    
         ACC=1.0D-16                                                         GWTLT.20    
      ENDIF                                                                  GWTLT.21    
      SA=DSQRT(.5D0)                                                         GWTLT.22    
      SB=DSQRT(1.5D0)                                                        GWTLT.23    
      SC=DSQRT(1.D0/3.D0)                                                    GWTLT.24    
      D1=1.D0                                                                GWTLT.25    
      D2=2.D0                                                                GWTLT.26    
      D4=4.D0                                                                GWTLT.27    
      NNN=JG+JG                                                              GWTLT.28    
      BN=NNN                                                                 GWTLT.29    
      GG=D2*BN+D1                                                            GWTLT.30    
      HH=8.*BN*BN                                                            GWTLT.31    
      K=0                                                                    GWTLT.32    
      AJ=J                                                                   GWTLT.33    
      TH=PI*(2.*AJ-.5)/GG                                                    GWTLT.34    
      DTH=TH+(COS(TH)/SIN(TH))/HH                                            GWTLT.35    
      X=DCOS(DTH)                                                            GWTLT.36    
54    CONTINUE                                                               GWTLT.37    
      AMM=SA                                                                 GWTLT.38    
      AMN=X*SB                                                               GWTLT.39    
      EM=SC                                                                  GWTLT.40    
      ANN=D1                                                                 GWTLT.41    
      DO 51 N=2,NNN                                                          GWTLT.42    
      ANN=ANN+D1                                                             GWTLT.43    
      RE=DSQRT(D4*ANN*ANN-D1)/ANN                                            GWTLT.44    
      A=RE*(X*AMN-EM*AMM)                                                    GWTLT.45    
      AMM=AMN                                                                GWTLT.46    
      AMN=A                                                                  GWTLT.47    
      EM=D1/RE                                                               GWTLT.48    
51    CONTINUE                                                               GWTLT.49    
      DD=GG*EM*AMM-X*ANN*A                                                   GWTLT.50    
      K=K+1                                                                  GWTLT.51    
      DLT=(D1-X*X)*A/DD                                                      GWTLT.52    
      IF (DABS(DLT).LT.ACC) GOTO 52                                          GWTLT.53    
      IF (K.GT.50) GOTO 53                                                   GWTLT.54    
      X=X-DLT                                                                GWTLT.55    
      GOTO 54                                                                GWTLT.56    
53    CONTINUE                                                               GWTLT.57    
      WRITE (2,105)                                                          GWTLT.58    
105   FORMAT(15H NO CONVERGENCE)                                             GWTLT.59    
52    CONTINUE                                                               GWTLT.60    
      WEIGHT=GG*(D1-X*X)/(DD*DD)                                             GWTLT.61    
      SIT=X                                                                  GWTLT.62    
      RETURN                                                                 GWTLT.63    
      END                                                                    GWTLT.64    
      INTEGER FUNCTION NLEAD(STRING)                                         GWTLT.65    
      CHARACTER STRING*(*),SPACE                                             GWTLT.66    
      PARAMETER(SPACE=' ')                                                   GWTLT.67    
      NLEAD=0                                                                GWTLT.68    
      DO 100 J=1,LEN(STRING)                                                 GWTLT.69    
      IF(STRING(J:J).NE.SPACE)RETURN                                         GWTLT.70    
      NLEAD=J                                                                GWTLT.71    
 100  CONTINUE                                                               GWTLT.72    
      END                                                                    GWTLT.73    
C     ******************************************************                 GWTLT.74    
      SUBROUTINE GSCOEFFS                                                    GSCOEFFS.2     
C                                                                            GSCOEFFS.3     
C     Read data from GRIB spectral files.                                    GSCOEFFS.4     
C                                                                            GSCOEFFS.5     
C     Adapted from R.Brugge's Package X.                                     GSCOEFFS.6     
C     Importantly flat triangular truncation is used.                        GSCOEFFS.7     
C                                                                            GSCOEFFS.8     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM           PARAMX.2     
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)                             PARAMX.3     
C                                                                            PARAMX.4     
      INTEGER JPACK                                                          PARAMG.2     
      PARAMETER(JPSEC0=2,JPSEC1=1024,JPSEC2=1024,JPSEC3=2,JPSEC4=512,        BUGS3EC.1     
     -      JPZ2=12+2*NL,JPZ3=2,JPACK=560000)                                BUGS3EC.2     
C-----------------------------------------------------------------------     PARAMG.5     
C     LIMITS ON GRIB PARAMETERS                                              PARAMG.6     
C                                                                            PARAMG.7     
C     NAME    MEANING                                                        PARAMG.8     
C     ----    -------                                                        PARAMG.9     
C     JPSEC0  Maximum size for ISEC0                                         PARAMG.10    
C     JPSEC1  Maximum size for ISEC1                                         PARAMG.11    
C     JPSEC2  Maximum size for ISEC2                                         PARAMG.12    
C     JPSEC3  Maximum size for ISEC3                                         PARAMG.13    
C     JPSEC4  Maximum size for ISEC4                                         PARAMG.14    
C     JPZ2    Maximum size for ZSEC2                                         PARAMG.15    
C     JPZ3    Maximum size for ZSEC3                                         PARAMG.16    
C     JPACK=280000 is large enough for T213 data                             PARAMG.17    
C-----------------------------------------------------------------------     PARAMG.18    
C                                                                            PARAMG.19    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
      COMMON/RESPECTR/RZ(JPFLSH,NL),RD(JPFLSH,NL),RT(JPFLSH,NL)              RESPECTR.2     
     :,RQ(JPFLSH,NL),RSP(JPFLSH)                                             RESPECTR.3     
C                                                                            RESPECTR.4     
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
C                                                                            GSCOEFFS.17    
      INTEGER INPFEND,KLEV                                                   Y2K.102   
      INTEGER IFIELD,ISTAT                                                   GSCOEFFS.18    
      INTEGER NVAR                                                           BUGS3EC.60    
      DIMENSION ZSEC4(JPFLSH)                                                GSCOEFFS.19    
C                                                                            Y2K.103   
C     Determine channel for required GRIB spectral file.                     Y2K.104   
C     Find filename for channel.                                             Y2K.105   
C                                                                            Y2K.106   
      IREC=NINT((DAY-BEGDAY)/THIST)                                          Y2K.107   
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)                                   Y2K.108   
      INPFEND=IOFFSET+7                                                      Y2K.109   
      IF (ISYY.GT.99) INPFEND=IOFFSET+9                                      Y2K.110   
      IF (IREM.EQ.0) THEN                                                    Y2K.111   
         CALL MAKENAME(FSTEM,IOFFSET,INPFNAME,NCDATE,LGPQ)                   Y2K.112   
         WRITE(LOUTP,*) 'Assuming file ',INPFNAME(1:INPFEND)                 Y2K.113   
     :        ,' is Cray unblocked'                                          Y2K.114   
         ISTAT=0                                                             Y2K.115   
C                                                                            Y2K.116   
C     Note that PBOPEN will change the channel number INPUT.                 Y2K.117   
C                                                                            Y2K.118   
         CALL PBOPEN(INPUT,INPFNAME(1:INPFEND),'r',ISTAT)                    Y2K.119   
         IF(ISTAT.NE.0) THEN                                                 Y2K.120   
            WRITE(LOUTP,*) 'Error opening file ',INPFNAME(1:INPFEND)         Y2K.121   
            WRITE(LOUTP,*) 'PBOPEN returns ISTAT = ',ISTAT                   Y2K.122   
            WRITE(LOUTP,*) 'Called from GSCOEFFS'                            Y2K.123   
            CALL ABORT                                                       Y2K.124   
         ELSE                                                                Y2K.125   
            PRINT *,INPFNAME(1:INPFEND),' OPENED'                            Y2K.126   
         ENDIF                                                               Y2K.127   
      ENDIF                                                                  Y2K.128   
      IF (LGPQ) THEN                                                         BUGS3EC.61    
         NVAR=4                                                              BUGS3EC.62    
      ELSE                                                                   BUGS3EC.63    
         NVAR=5                                                              BUGS3EC.64    
      ENDIF                                                                  BUGS3EC.65    
C                                                                            GSCOEFFS.42    
C     Unpack ln(surface pressure).                                           GSCOEFFS.43    
C                                                                            GSCOEFFS.44    
      IFIELD=0                                                               Y2K.129   
      CALL SPUNPACK(RSP,JPFLSH,INPUT,IFIELD,KLEV)                            Y2K.130   
      IF (IFIELD.NE.152) THEN                                                GSCOEFFS.46    
         WRITE(LOUTP,*) 'The first field is not ln(surface pressure).'       GSCOEFFS.47    
         STOP                                                                GSCOEFFS.48    
      ENDIF                                                                  GSCOEFFS.49    
C                                                                            GSCOEFFS.50    
C     Loop over variables T,Q,Z,D for all levels.                            GSCOEFFS.51    
C                                                                            GSCOEFFS.52    
      NVAR=3                                                                 PSIATTR.18    
      DO 440 L=1,NL                                                          GSCOEFFS.53    
         DO 450 IVAR=1,NVAR                                                  BUGS3EC.66    
            CALL SPUNPACK(ZSEC4,JPFLSH,INPUT,IFIELD,KLEV)                    Y2K.131   
C                                                                            GSCOEFFS.56    
C     Write single level spectral field to appropriate array.                GSCOEFFS.57    
C     The fields are non-dimensionalised for later grid point                GSCOEFFS.58    
C     calculations.                                                          GSCOEFFS.59    
C                                                                            GSCOEFFS.60    
            IF (IFIELD.EQ.138) THEN                                          GSCOEFFS.61    
               DO 300 I=1,JPFLSH                                             GSCOEFFS.62    
                  RZ(I,L)=ZSEC4(I)/WW                                        GSCOEFFS.63    
 300           CONTINUE                                                      GSCOEFFS.64    
            ENDIF                                                            GSCOEFFS.65    
            IF (IFIELD.EQ.155) THEN                                          GSCOEFFS.66    
               DO 310 I=1,JPFLSH                                             GSCOEFFS.67    
                  RD(I,L)=ZSEC4(I)/WW                                        GSCOEFFS.68    
 310           CONTINUE                                                      GSCOEFFS.69    
            ENDIF                                                            GSCOEFFS.70    
            IF (IFIELD.EQ.130) THEN                                          GSCOEFFS.71    
               DO 320 I=1,JPFLSH                                             GSCOEFFS.72    
                  RT(I,L)=ZSEC4(I)/CT                                        GSCOEFFS.73    
 320           CONTINUE                                                      GSCOEFFS.74    
            ENDIF                                                            GSCOEFFS.75    
            IF (IFIELD.EQ.133) THEN                                          GSCOEFFS.76    
               DO 330 I=1,JPFLSH                                             GSCOEFFS.77    
                  RQ(I,L)=ZSEC4(I)/CQ                                        GSCOEFFS.78    
 330           CONTINUE                                                      GSCOEFFS.79    
            ENDIF                                                            GSCOEFFS.80    
C                                                                            GSCOEFFS.81    
 450     CONTINUE                                                            GSCOEFFS.82    
 440  CONTINUE                                                               GSCOEFFS.83    
C                                                                            GSCOEFFS.84    
C     Close input file.                                                      GSCOEFFS.85    
C                                                                            GSCOEFFS.86    
      IF (IREM.EQ.NRECPFILE-1) THEN                                          GSCOEFFS.87    
         ISTAT=0                                                             GSCOEFFS.88    
         CALL PBCLOSE(INPUT,ISTAT)                                           GSCOEFFS.89    
         IF(ISTAT.NE.0) THEN                                                 GSCOEFFS.90    
            WRITE(LOUTP,*) 'ERROR CLOSING FILE ',INPFNAME(1:INPFEND)         Y2K.132   
            WRITE(LOUTP,*) 'ISTAT = ',ISTAT                                  GSCOEFFS.92    
            CALL ABORT                                                       GSCOEFFS.93    
         ENDIF                                                               GSCOEFFS.94    
      ENDIF                                                                  GSCOEFFS.95    
C                                                                            GSCOEFFS.96    
      RETURN                                                                 GSCOEFFS.97    
      END                                                                    GSCOEFFS.98    
C     ***************************************************************        GSCOEFFS.99    
      SUBROUTINE GPQREAD                                                     GPQREAD.2     
C                                                                            GPQREAD.3     
C     Read specific humidity data from GRIB Gaussian grid.                   GPQREAD.4     
C                                                                            GPQREAD.5     
C     Adapted from R.Brugge's Package X.                                     GPQREAD.6     
C                                                                            GPQREAD.7     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM           PARAMX.2     
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)                             PARAMX.3     
C                                                                            PARAMX.4     
      INTEGER JPACK                                                          PARAMG.2     
      PARAMETER(JPSEC0=2,JPSEC1=1024,JPSEC2=1024,JPSEC3=2,JPSEC4=512,        BUGS3EC.1     
     -      JPZ2=12+2*NL,JPZ3=2,JPACK=560000)                                BUGS3EC.2     
C-----------------------------------------------------------------------     PARAMG.5     
C     LIMITS ON GRIB PARAMETERS                                              PARAMG.6     
C                                                                            PARAMG.7     
C     NAME    MEANING                                                        PARAMG.8     
C     ----    -------                                                        PARAMG.9     
C     JPSEC0  Maximum size for ISEC0                                         PARAMG.10    
C     JPSEC1  Maximum size for ISEC1                                         PARAMG.11    
C     JPSEC2  Maximum size for ISEC2                                         PARAMG.12    
C     JPSEC3  Maximum size for ISEC3                                         PARAMG.13    
C     JPSEC4  Maximum size for ISEC4                                         PARAMG.14    
C     JPZ2    Maximum size for ZSEC2                                         PARAMG.15    
C     JPZ3    Maximum size for ZSEC3                                         PARAMG.16    
C     JPACK=280000 is large enough for T213 data                             PARAMG.17    
C-----------------------------------------------------------------------     PARAMG.18    
C                                                                            PARAMG.19    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
C                                                                            GPQREAD.16    
      PARAMETER(ILEN4=MG*JGG)                                                GPQREAD.17    
      INTEGER IREC,IREM,INPFEND,IFIELD,KLEV,ISTAT                            Y2K.133   
      DIMENSION ZSEC4(ILEN4),QGLA(MG,JGG,NL)                                 GPQREAD.19    
C                                                                            Y2K.134   
C     Determine channel for required GRIB spectral file.                     Y2K.135   
C     Find filename for channel.                                             Y2K.136   
C                                                                            Y2K.137   
      IREC=NINT((DAY-BEGDAY)/THIST)                                          Y2K.138   
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)                                   Y2K.139   
      INPFEND=IOFFSET+7                                                      Y2K.140   
      IF (ISYY.GT.99) INPFEND=IOFFSET+9                                      Y2K.141   
      IF (IREM.EQ.0) THEN                                                    Y2K.142   
         CALL MAKENAME(FSTEM2,IOFFSET,INPFNAME,NCDATE,LGPQ)                  Y2K.143   
         WRITE(LOUTP,*) 'Assuming file ',INPFNAME(1:INPFEND)                 Y2K.144   
     :        ,' is Cray unblocked'                                          Y2K.145   
         ISTAT=0                                                             Y2K.146   
C                                                                            Y2K.147   
C     Note that PBOPEN will change the channel number INPUT.                 Y2K.148   
C                                                                            Y2K.149   
         CALL PBOPEN(INPUT2,INPFNAME(1:INPFEND),'r',ISTAT)                   Y2K.150   
         IF(ISTAT.NE.0) THEN                                                 Y2K.151   
            WRITE(LOUTP,*) 'Error opening file ',INPFNAME(1:INPFEND)         Y2K.152   
            WRITE(LOUTP,*) 'PBOPEN returns ISTAT = ',ISTAT                   Y2K.153   
            WRITE(LOUTP,*) 'Called from GPQREAD'                             Y2K.154   
            CALL ABORT                                                       Y2K.155   
         ELSE                                                                Y2K.156   
            PRINT *,INPFNAME(1:INPFEND),' OPENED'                            Y2K.157   
         ENDIF                                                               Y2K.158   
      ENDIF                                                                  Y2K.159   
C                                                                            GPQREAD.42    
C     Unpack specific humidity data.                                         GPQREAD.43    
C                                                                            GPQREAD.44    
      DO 10 L=1,NL                                                           GPQREAD.45    
         IFIELD=0                                                            Y2K.160   
         CALL SPUNPACK(ZSEC4,ILEN4,INPUT2,IFIELD,KLEV)                       Y2K.161   
         IF (IFIELD.NE.133) THEN                                             GPQREAD.47    
            WRITE(LOUTP,*) 'The field is not specific humidity.'             GPQREAD.48    
            STOP                                                             GPQREAD.49    
         ENDIF                                                               GPQREAD.50    
         II=0                                                                GPQREAD.51    
         DO 20 J=1,JGG                                                       GPQREAD.52    
            DO 30 I=1,MG                                                     GPQREAD.53    
               II=II+1                                                       GPQREAD.54    
               QGLA(I,J,L)=ZSEC4(II)                                         GPQREAD.55    
 30         CONTINUE                                                         GPQREAD.56    
 20      CONTINUE                                                            GPQREAD.57    
 10   CONTINUE                                                               GPQREAD.58    
C                                                                            GPQREAD.59    
C     Write specific humidity to a scratch file.                             GPQREAD.60    
C                                                                            GPQREAD.61    
      INORTH=0                                                               GPQREAD.62    
      ISOUTH=MGPP                                                            GPQREAD.63    
      DO 40 J=1,JG                                                           GPQREAD.64    
         JSOUTH=JGGP-J                                                       GPQREAD.65    
         DO 50 L=1,NL                                                        GPQREAD.66    
            LL=(L-1)*IGC                                                     GPQREAD.67    
            DO 60 I=1,MG                                                     GPQREAD.68    
               QG(LL+INORTH+I)=QGLA(I,J,L)                                   GPQREAD.69    
               QG(LL+ISOUTH+I)=QGLA(I,JSOUTH,L)                              GPQREAD.70    
 60         CONTINUE                                                         GPQREAD.71    
 50      CONTINUE                                                            GPQREAD.72    
         WRITE(NCGP(4)) QG                                                   GPQREAD.73    
 40   CONTINUE                                                               GPQREAD.74    
C                                                                            GPQREAD.75    
C     Close input file.                                                      GPQREAD.76    
C                                                                            GPQREAD.77    
      IF (IREM.EQ.0) THEN                                                    GPQREAD.78    
         ISTAT=0                                                             GPQREAD.79    
         CALL PBCLOSE(INPUT2,ISTAT)                                          GPQREAD.80    
         IF(ISTAT.NE.0) THEN                                                 GPQREAD.81    
            WRITE(LOUTP,*) 'ERROR CLOSING FILE ',INPFNAME(1:INPFEND)         Y2K.162   
            WRITE(LOUTP,*) 'ISTAT = ',ISTAT                                  GPQREAD.83    
            CALL ABORT                                                       GPQREAD.84    
         ENDIF                                                               GPQREAD.85    
      ENDIF                                                                  GPQREAD.86    
C                                                                            GPQREAD.87    
      RETURN                                                                 GPQREAD.88    
      END                                                                    GPQREAD.89    
C     ***************************************************************        GPQREAD.90    
      SUBROUTINE SPUNPACK(ZSEC4,ILEN4,ICHAN,IFIELD,ILEV)                     Y2K.223   
C                                                                            SPUNPACK.3     
C     Read and unpack data from GRIB spectral files.                         SPUNPACK.4     
C                                                                            SPUNPACK.5     
C     Adapted from R.Brugge's Package X.                                     SPUNPACK.6     
C     Importantly flat triangular truncation is used.                        SPUNPACK.7     
C                                                                            SPUNPACK.8     
C     NOTE: CHANS/IWORDSIZE is number of bytes per INTEGER word.             SPUNPACK.9     
C                                                                            SPUNPACK.10    
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM           PARAMX.2     
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)                             PARAMX.3     
C                                                                            PARAMX.4     
      INTEGER JPACK                                                          PARAMG.2     
      PARAMETER(JPSEC0=2,JPSEC1=1024,JPSEC2=1024,JPSEC3=2,JPSEC4=512,        BUGS3EC.1     
     -      JPZ2=12+2*NL,JPZ3=2,JPACK=560000)                                BUGS3EC.2     
C-----------------------------------------------------------------------     PARAMG.5     
C     LIMITS ON GRIB PARAMETERS                                              PARAMG.6     
C                                                                            PARAMG.7     
C     NAME    MEANING                                                        PARAMG.8     
C     ----    -------                                                        PARAMG.9     
C     JPSEC0  Maximum size for ISEC0                                         PARAMG.10    
C     JPSEC1  Maximum size for ISEC1                                         PARAMG.11    
C     JPSEC2  Maximum size for ISEC2                                         PARAMG.12    
C     JPSEC3  Maximum size for ISEC3                                         PARAMG.13    
C     JPSEC4  Maximum size for ISEC4                                         PARAMG.14    
C     JPZ2    Maximum size for ZSEC2                                         PARAMG.15    
C     JPZ3    Maximum size for ZSEC3                                         PARAMG.16    
C     JPACK=280000 is large enough for T213 data                             PARAMG.17    
C-----------------------------------------------------------------------     PARAMG.18    
C                                                                            PARAMG.19    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
C                                                                            SPUNPACK.19    
      INTEGER INP(JPACK),ILEN4,ICHAN,IFIELD,ISTAT,ILENB1,ILEN1               SPUNPACK.20    
      INTEGER ILEV,NLEVPAR,JLATS                                             Y2K.224   
      LOGICAL LETASET                                                        Y2K.225   
      REAL DLAMTEST,DPHITEST                                                 Y2K.226   
      LOGICAL LOINFO                                                         SPUNPACK.21    
      DIMENSION ISEC0(JPSEC0),ISEC1(JPSEC1),ISEC2(JPSEC2),                   SPUNPACK.22    
     -      ISEC3(JPSEC3),ISEC4(JPSEC4)                                      SPUNPACK.23    
      DIMENSION ZSEC2(JPZ2),ZSEC3(JPZ3),ZSEC4(ILEN4)                         SPUNPACK.24    
C                                                                            SPUNPACK.25    
C                                                                            Y2K.227   
C     Use negative IFIELD to indicate that eta level                         Y2K.228   
C     info must be copied to ALEVH.                                          Y2K.229   
C                                                                            Y2K.230   
      IF (IFIELD.LT.0) THEN                                                  Y2K.231   
         LETASET=.TRUE.                                                      Y2K.232   
      ELSE                                                                   Y2K.233   
         LETASET=.FALSE.                                                     Y2K.234   
      ENDIF                                                                  Y2K.235   
      ISTAT=0                                                                SPUNPACK.26    
      ILENB1=IWORDSIZE*JPACK                                                 SPUNPACK.27    
      CALL PBGRIB(ICHAN,INP,ILENB1,ILEN1,ISTAT)                              SPUNPACK.28    
      ILEN=ILEN1/IWORDSIZE                                                   SPUNPACK.29    
      IF (MOD(ILEN1,IWORDSIZE).NE.0) ILEN=ILEN+1                             SPUNPACK.30    
      IF (ISTAT.EQ.0) THEN                                                   SPUNPACK.31    
         LOINFO=.FALSE.                                                      SPUNPACK.32    
         CALL RDGRIB(INP,JPACK,LOINFO,IDATE,IFIELD,ILEV,                     SPUNPACK.33    
     -        ISEC0,ISEC1,ISEC2,ISEC3,ISEC4,ZSEC2,ZSEC3,ZSEC4,               SPUNPACK.34    
     -        ILEN4)                                                         SPUNPACK.35    
      ELSEIF (ISTAT.EQ.-1) THEN                                              SPUNPACK.36    
         WRITE(LOUTP,*)'END-OF-FILE HAS BEEN REACHED'                        SPUNPACK.37    
      ELSE                                                                   SPUNPACK.38    
         WRITE(LOUTP,*)'SIZE OF BUFFER IS NOT SUFFICIENT'                    SPUNPACK.39    
         CALL ABORT                                                          SPUNPACK.40    
      ENDIF                                                                  SPUNPACK.41    
C                                                                            SPUNPACK.42    
C     Check whether data is formed of spectral harmonics.                    SPUNPACK.43    
C                                                                            SPUNPACK.44    
      IF(ISEC2(1).EQ.50) THEN                                                SPUNPACK.45    
         IF(.NOT.LSPECTRAL) THEN                                             SPUNPACK.46    
            WRITE(LOUTP,*)'SPECTRAL FIELD DETECTED'                          SPUNPACK.47    
            STOP                                                             SPUNPACK.48    
         ENDIF                                                               SPUNPACK.49    
C                                                                            SPUNPACK.50    
C     Check input truncation.                                                SPUNPACK.51    
C                                                                            SPUNPACK.52    
         ITRUNC=ISEC2(2)                                                     SPUNPACK.53    
         ITRUN2=ISEC2(3)                                                     SPUNPACK.54    
         ITRUN3=ISEC2(4)                                                     SPUNPACK.55    
         IF(ITRUNC.NE.ITRUN2.OR.ITRUNC.NE.ITRUN3) THEN                       SPUNPACK.56    
            WRITE(LOUTP,*)'INPUT FIELD NOT TRIANGULAR TRUNCATION'            SPUNPACK.57    
            CALL ABORT                                                       SPUNPACK.58    
         ENDIF                                                               SPUNPACK.59    
         IF(ITRUNC.NE.NN) THEN                                               SPUNPACK.60    
            WRITE(LOUTP,*)'INPUT FIELD TRUNCATION DOES NOT MATCH NN'         SPUNPACK.61    
            CALL ABORT                                                       SPUNPACK.62    
         ENDIF                                                               SPUNPACK.63    
      ENDIF                                                                  SPUNPACK.64    
C                                                                            Y2K.236   
C     Check to see if grid is regular lon-lat.                               Y2K.237   
C                                                                            Y2K.238   
      IF(ISEC2(1).EQ.0) THEN                                                 Y2K.239   
         WRITE(LOUTP,*)'Data is on a regular lon-lat grid.'                  Y2K.240   
         IF (ISEC2(2).NE.MG) THEN                                            Y2K.241   
            WRITE(LOUTP,1001) ISEC2(2),MG                                    Y2K.242   
            STOP                                                             Y2K.243   
         ENDIF                                                               Y2K.244   
         JLATS=ILEN4/MG                                                      Y2K.245   
         IF (ISEC2(3).NE.JLATS) THEN                                         Y2K.246   
            WRITE(LOUTP,1002) ISEC2(3),JLATS                                 Y2K.247   
            STOP                                                             Y2K.248   
         ENDIF                                                               Y2K.249   
         DLAMTEST=ABS(FLOAT(ISEC2(9))/1000.-DLAM*180./PI)                    Y2K.250   
         IF (DLAMTEST.GT.1.E-4) THEN                                         Y2K.251   
            WRITE(LOUTP,1003) FLOAT(ISEC2(9))/1000.,DLAM*180./PI             Y2K.252   
            STOP                                                             Y2K.253   
         ENDIF                                                               Y2K.254   
         DPHITEST=ABS(FLOAT(ISEC2(10))/1000.-90./FLOAT(JG+1))                Y2K.255   
         IF (DPHITEST.GT.1.E-4) THEN                                         Y2K.256   
            WRITE(LOUTP,1004) FLOAT(ISEC2(10))/1000.,90./FLOAT(JG+1)         Y2K.257   
            STOP                                                             Y2K.258   
         ENDIF                                                               Y2K.259   
      ENDIF                                                                  Y2K.260   
C                                                                            SPUNPACK.65    
C     Check on levels.                                                       SPUNPACK.66    
C                                                                            SPUNPACK.67    
      IF (ILEVTYPE.EQ.0) THEN                                                SPUNPACK.68    
         IF (ISEC1(7).EQ.109) THEN                                           Y2K.261   
            NLEVPAR=ISEC2(12)                                                Y2K.262   
            IF (NLEVPAR.NE.(2*NLP)) THEN                                     Y2K.263   
               WRITE(LOUTP,1010) NLEVPAR/2,NLP                               Y2K.264   
               STOP                                                          Y2K.265   
            ENDIF                                                            Y2K.266   
            IF (LETASET) THEN                                                Y2K.267   
               DO 200 L=1,NLP                                                Y2K.268   
                  AETA(L)=ZSEC2(10+L)/P0                                     Y2K.269   
                  BETA(L)=ZSEC2(10+NLP+L)                                    Y2K.270   
                  WRITE(LOUTP,1011) L-1,AETA(L),BETA(L)                      Y2K.271   
 200           CONTINUE                                                      Y2K.272   
            ENDIF                                                            Y2K.273   
         ELSEIF (ISEC1(7).EQ.1) THEN                                         Y2K.274   
C            WRITE(LOUTP,*)' SURFACE DATA FOUND.'                            Y2K.275   
         ELSE                                                                Y2K.276   
            WRITE(LOUTP,1000) ISEC1(7)                                       Y2K.277   
            STOP                                                             Y2K.278   
         ENDIF                                                               Y2K.279   
      ENDIF                                                                  SPUNPACK.73    
      IF (ILEVTYPE.EQ.1) THEN                                                SPUNPACK.74    
         IF ((ISEC1(7).NE.100).AND.(ISEC1(7).NE.1)) THEN                     SPUNPACK.75    
            WRITE(LOUTP,1000) ISEC1(7)                                       SPUNPACK.76    
            STOP                                                             SPUNPACK.77    
         ENDIF                                                               SPUNPACK.78    
      ENDIF                                                                  SPUNPACK.79    
C                                                                            SPUNPACK.80    
 1000 FORMAT(/' LEVEL INDICATOR VALUE ',I3,' NOT EXPECTED.')                 SPUNPACK.81    
 1001 FORMAT(/' NLON IN DATA = ',I5,' BUT EXPECTED ',I5)                     Y2K.280   
 1002 FORMAT(/' NLAT IN DATA = ',I5,' BUT EXPECTED ',I5)                     Y2K.281   
 1003 FORMAT(/' LON SPACING IN DATA = ',F9.4,' BUT EXPECTED ',F9.4)          Y2K.282   
 1004 FORMAT(/' LAT SPACING IN DATA = ',F9.4,' BUT EXPECTED ',F9.4)          Y2K.283   
 1010 FORMAT(/' N HALF-LEVELS IN DATA = ',I5,' BUT EXPECTED ',I5)            Y2K.284   
 1011 FORMAT(I5,(2E16.9))                                                    Y2K.285   
C                                                                            SPUNPACK.82    
      RETURN                                                                 SPUNPACK.83    
      END                                                                    SPUNPACK.84    
C     ***************************************************************        SPUNPACK.85    
      SUBROUTINE RDGRIB(INP,ILENB,LINFO,KDATE,KFIELD,KLEV,                   RDGRIB.2     
     -      ISEC0,ISEC1,ISEC2,ISEC3,ISEC4,ZSEC2,ZSEC3,ZSEC4,ILEN4)           RDGRIB.3     
C                                                                            RDGRIB.4     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      INTEGER JPACK                                                          PARAMG.2     
      PARAMETER(JPSEC0=2,JPSEC1=1024,JPSEC2=1024,JPSEC3=2,JPSEC4=512,        BUGS3EC.1     
     -      JPZ2=12+2*NL,JPZ3=2,JPACK=560000)                                BUGS3EC.2     
C-----------------------------------------------------------------------     PARAMG.5     
C     LIMITS ON GRIB PARAMETERS                                              PARAMG.6     
C                                                                            PARAMG.7     
C     NAME    MEANING                                                        PARAMG.8     
C     ----    -------                                                        PARAMG.9     
C     JPSEC0  Maximum size for ISEC0                                         PARAMG.10    
C     JPSEC1  Maximum size for ISEC1                                         PARAMG.11    
C     JPSEC2  Maximum size for ISEC2                                         PARAMG.12    
C     JPSEC3  Maximum size for ISEC3                                         PARAMG.13    
C     JPSEC4  Maximum size for ISEC4                                         PARAMG.14    
C     JPZ2    Maximum size for ZSEC2                                         PARAMG.15    
C     JPZ3    Maximum size for ZSEC3                                         PARAMG.16    
C     JPACK=280000 is large enough for T213 data                             PARAMG.17    
C-----------------------------------------------------------------------     PARAMG.18    
C                                                                            PARAMG.19    
      INTEGER ILENB, KDATE, KFIELD, KLEV, INP(ILENB)                         RDGRIB.6     
      LOGICAL LINFO                                                          RDGRIB.7     
C                                                                            RDGRIB.8     
      INTEGER ISEC0(JPSEC0),ISEC1(JPSEC1),ISEC2(JPSEC2),                     RDGRIB.9     
     -      ISEC3(JPSEC3),ISEC4(JPSEC4)                                      RDGRIB.10    
      REAL ZSEC2(JPZ2), ZSEC3(JPZ3), ZSEC4(ILEN4)                            RDGRIB.11    
      INTEGER ILEN4, IERR, IWORD                                             RDGRIB.12    
      CHARACTER OPER*1                                                       RDGRIB.13    
C                                                                            RDGRIB.14    
C     Initialise                                                             RDGRIB.15    
C                                                                            RDGRIB.16    
      OPER='R'                                                               BUGS3EC.68    
      CALL GRIBEX(ISEC0,ISEC1,ISEC2,ZSEC2,ISEC3,ZSEC3,ISEC4,                 RDGRIB.18    
     +     ZSEC4,ILEN4,INP,ILENB,IWORD,OPER,IERR)                            RDGRIB.19    
      IF (IERR.NE.0) THEN                                                    RDGRIB.20    
         WRITE(*,*) 'ERROR reading data with GRIBEX.'                        RDGRIB.21    
         WRITE(*,*) 'Return code IERR = ',IERR                               RDGRIB.22    
      ENDIF                                                                  RDGRIB.23    
      KDATE=ISEC1(10)*1000000+ISEC1(11)*10000+                               RDGRIB.24    
     +     ISEC1(12)*100+ISEC1(13)                                           RDGRIB.25    
      KFIELD=ISEC1(6)                                                        RDGRIB.26    
      KLEV=ISEC1(8)                                                          RDGRIB.27    
C                                                                            RDGRIB.28    
C     Write GRIB information                                                 RDGRIB.29    
C                                                                            RDGRIB.30    
      IF (LINFO) THEN                                                        RDGRIB.31    
         CALL GRPRS0 (ISEC0)                                                 RDGRIB.32    
         CALL GRPRS1 (ISEC0,ISEC1)                                           RDGRIB.33    
         IF (ISEC1(5).NE.0 .AND. ISEC1(5).NE.64) THEN                        RDGRIB.34    
            CALL GRPRS2 (ISEC0,ISEC2,ZSEC2)                                  RDGRIB.35    
         ENDIF                                                               RDGRIB.36    
         IF (ISEC1(5).NE.0 .AND. ISEC1(5).NE.128) THEN                       RDGRIB.37    
            CALL GRPRS3 (ISEC0,ISEC3,ZSEC3)                                  RDGRIB.38    
         ENDIF                                                               RDGRIB.39    
      ENDIF                                                                  RDGRIB.40    
C                                                                            RDGRIB.41    
      RETURN                                                                 RDGRIB.42    
      END                                                                    RDGRIB.43    
C     ****************************************************************       RDGRIB.44    
      SUBROUTINE GSP2GRID                                                    GSP2GRID.2     
C                                                                            GSP2GRID.3     
C     Transform from spectral data (REAL arrays) to grid point               GSP2GRID.4     
C     space. Horizontal derivatives are taken by multiplying                 GSP2GRID.5     
C     Legendre functions by appropriate factors.                             GSP2GRID.6     
C                                                                            GSP2GRID.7     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM           PARAMX.2     
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)                             PARAMX.3     
C                                                                            PARAMX.4     
      PARAMETER(IDDAG=NLWG*IGC)                                              GSP2GRID.11    
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/RESPECTR/RZ(JPFLSH,NL),RD(JPFLSH,NL),RT(JPFLSH,NL)              RESPECTR.2     
     :,RQ(JPFLSH,NL),RSP(JPFLSH)                                             RESPECTR.3     
C                                                                            RESPECTR.4     
      COMMON/COMFFT/NTWG,NRSTWG,TRIG(IDA),WORK(IDF),IFAX(10)                 COMFFT.2     
C                                                                            COMFFT.3     
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/LEGAU/                                                          LEGAU.2     
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)       LEGAU.3     
     :,JH,JL                                                                 LEGAU.4     
C                                                                            LEGAU.5     
      COMMON/LEGAUGS/                                                        LEGAUGS.2     
     : ALEG(JLEGP),DYLEG(JLEGP),DM2LEG(JLEGP),DYDM2LEG(JLEGP)                LEGAUGS.3     
C     *****************************************************************      LEGAUGS.4     
      REAL DAG(IDDAG),ZM,ZN                                                  GSP2GRID.19    
      EQUIVALENCE (DAG(1),UG(1))                                             GSP2GRID.20    
C                                                                            GSP2GRID.21    
C     Statement functions.                                                   GSP2GRID.22    
C                                                                            GSP2GRID.23    
      REAL DD,PM,PN                                                          GSP2GRID.24    
      DD(PM,PN)=SQRT((PN*PN-PM*PM)/(4.*PN*PN-1.))/PN                         GSP2GRID.25    
C                                                                            GSP2GRID.26    
C     Calculate the Legendre polynomials at current latitude.                GSP2GRID.27    
C                                                                            GSP2GRID.28    
      CALL JSPLEG2(ALEG,ALAT(JL),NN)                                         GSP2GRID.29    
C                                                                            GSP2GRID.30    
C     Calculate extra polynomial for                                         GSP2GRID.31    
C     (1-mu^2)*d/d(mu) del^-2 P(m,n) using recurrence relation.              GSP2GRID.32    
C                                                                            GSP2GRID.33    
      K=1                                                                    GSP2GRID.34    
C                                                                            GSP2GRID.35    
C     For m=0 to m=N-1                                                       GSP2GRID.36    
C                                                                            GSP2GRID.37    
      DO 10 JM=1,MM                                                          GSP2GRID.38    
C                                                                            GSP2GRID.39    
C     For n=m                                                                GSP2GRID.40    
C                                                                            GSP2GRID.41    
         ZM=JM-1.                                                            GSP2GRID.42    
         ZN=ZM                                                               GSP2GRID.43    
         DYDM2LEG(K)=DD(ZM,ZN+1)*ALEG(K+1)                                   GSP2GRID.44    
         K=K+1                                                               GSP2GRID.45    
         JMP=JM+1                                                            GSP2GRID.46    
C                                                                            GSP2GRID.47    
C     For n=m+1 to n=N                                                       GSP2GRID.48    
C                                                                            GSP2GRID.49    
         DO 20 JN=JMP,NN+1                                                   GSP2GRID.50    
            ZN=JN-1.                                                         GSP2GRID.51    
            DYDM2LEG(K)=-DD(ZM,ZN)*ALEG(K-1)+DD(ZM,ZN+1)*ALEG(K+1)           GSP2GRID.52    
            K=K+1                                                            GSP2GRID.53    
 20      CONTINUE                                                            GSP2GRID.54    
C                                                                            GSP2GRID.55    
C     For n=N+1                                                              GSP2GRID.56    
C                                                                            GSP2GRID.57    
         DYDM2LEG(K)=0.                                                      GSP2GRID.58    
         K=K+1                                                               GSP2GRID.59    
 10   CONTINUE                                                               GSP2GRID.60    
C                                                                            GSP2GRID.61    
C     For m=n=N and m=N,n=N+1                                                GSP2GRID.62    
C                                                                            GSP2GRID.63    
      ZM=NN                                                                  GSP2GRID.64    
      ZN=ZM                                                                  GSP2GRID.65    
      DYDM2LEG(K)=DD(ZM,ZN+1)*ALEG(K+1)                                      GSP2GRID.66    
      K=K+1                                                                  GSP2GRID.67    
      DYDM2LEG(K)=0.                                                         GSP2GRID.68    
C                                                                            GSP2GRID.69    
C     Calculate remaining two polynomials:-                                  GSP2GRID.70    
C     (1-mu^2)d/d(mu) P(m,n)  and  del^-2 P(m,n).                            GSP2GRID.71    
C                                                                            GSP2GRID.72    
      K=1                                                                    GSP2GRID.73    
      DO 30 JM=1,MM+1                                                        GSP2GRID.74    
         DO 40 JN=JM,NN+2                                                    GSP2GRID.75    
            DM2LEG(K)=-RSQ(JN)*ALEG(K)                                       GSP2GRID.76    
            DYLEG(K)=-SQ(JN)*DYDM2LEG(K)                                     GSP2GRID.77    
            K=K+1                                                            GSP2GRID.78    
 40      CONTINUE                                                            GSP2GRID.79    
 30   CONTINUE                                                               GSP2GRID.80    
C                                                                            GSP2GRID.81    
C     Inverse Legendre transforms, from spectral to Fourier space.           GSP2GRID.82    
C                                                                            GSP2GRID.83    
      CALL LTIEC                                                             GSP2GRID.84    
C                                                                            GSP2GRID.85    
C     FFT from Fourier to grid point space.                                  GSP2GRID.86    
C     (UG-->PMG equivalenced in DAG).                                        GSP2GRID.87    
C                                                                            GSP2GRID.88    
      NTWG=NLWG*NHEM                                                         FFTCHANGE.2     
      CALL FFT991(DAG,WORK,TRIG,IFAX,1,MGPP,MG,NTWG,1)                       FFTCHANGE.3     
C                                                                            GSP2GRID.96    
C     Transform specific humidity.                                           GSP2GRID.97    
C                                                                            GSP2GRID.98    
      IF (LQATTR.AND.(.NOT.LGPQ)) THEN                                       GSP2GRID.99    
      N1=NL*NHEM                                                             FFTCHANGE.4     
      CALL FFT991(QG,WORK,TRIG,IFAX,1,MGPP,MG,N1,1)                          FFTCHANGE.5     
      ENDIF                                                                  GSP2GRID.109   
C                                                                            GSP2GRID.110   
C     Convert ln(surface pressure) to non-dimensionalised                    GSP2GRID.111   
C     surface pressure.                                                      GSP2GRID.112   
C                                                                            GSP2GRID.113   
      DO 900 I=1,IGC                                                         GSP2GRID.114   
         PLG(I)=EXP( PLG(I) )/P0                                             GSP2GRID.115   
 900  CONTINUE                                                               GSP2GRID.116   
C                                                                            GSP2GRID.117   
      RETURN                                                                 GSP2GRID.118   
      END                                                                    GSP2GRID.119   
C     **********************************************************             GSP2GRID.120   
      SUBROUTINE JSPLEG2(PLEG,PLAT,KTRUNC)                                   JSPLEG2.2     
**    Function - calculate Legendre functions for a single latitude          JSPLEG2.3     
**          assuming a flat Triangular truncation                            JSPLEG2.4     
**    Args in -                                                              JSPLEG2.5     
**               PLAT    - Latitude (radians)                                JSPLEG2.6     
**               KTRUNC  - Triangular truncation                             JSPLEG2.7     
**    Args out -                                                             JSPLEG2.8     
**               PLEG    - Legendre functions                                JSPLEG2.9     
**                         The array must be at least                        JSPLEG2.10    
**                         (KTRUNC+1)*(KTRUNC+4)/2 words long.               JSPLEG2.11    
**    Args for work - none                                                   JSPLEG2.12    
**    Com used - none                                                        JSPLEG2.13    
**    Com changed - none                                                     JSPLEG2.14    
**    Params used - none                                                     JSPLEG2.15    
**    Called by - OPTION3                                                    JSPLEG2.16    
**    Calls - none                                                           JSPLEG2.17    
**    Files read - none                                                      JSPLEG2.18    
**    Files written - none                                                   JSPLEG2.19    
**    Author - R Brugge, University of Reading, based on code by             JSPLEG2.20    
**          J D Chambers, ECMWF                                              JSPLEG2.21    
                                                                             JSPLEG2.22    
**    Uses a recurrence relation with explicit relations for P(m,m) and      JSPLEG2.23    
**    P(m,m+1)                                                               JSPLEG2.24    
C                                                                            JSPLEG2.25    
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM           PARAMX.2     
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)                             PARAMX.3     
C                                                                            PARAMX.4     
      PARAMETER (JPTRNC=JPNNX)                                               JSPLEG2.28    
      PARAMETER (JPTRP1=(JPTRNC+1)*(JPTRNC+4))                               JSPLEG2.29    
      DIMENSION PLEG(*)                                                      JSPLEG2.30    
      DIMENSION ZHLP1(JPTRP1),ZHLP2(JPTRP1),ZHLP3(JPTRP1)                    JSPLEG2.31    
                                                                             JSPLEG2.32    
      ITOUT1=KTRUNC+1                                                        JSPLEG2.33    
      ZSIN=SIN(PLAT)                                                         JSPLEG2.34    
      ZCOS=SQRT(1.-ZSIN*ZSIN)                                                JSPLEG2.35    
                                                                             JSPLEG2.36    
**    Step 1.        M = 0, N = 0 and N = 1                                  JSPLEG2.37    
      ILM=2                                                                  JSPLEG2.38    
      PLEG(1)=1.0                                                            JSPLEG2.39    
      ZF1M=SQRT(3.0)                                                         JSPLEG2.40    
      PLEG(2)=ZF1M*ZSIN                                                      JSPLEG2.41    
                                                                             JSPLEG2.42    
**    Step 2.       Sum for M = 0 to T (T = truncation)                      JSPLEG2.43    
      DO 205 JM=2,ITOUT1                                                     JSPLEG2.44    
      ZM= JM-1                                                               JSPLEG2.45    
      ZHLP1(JM)=SQRT(2.*ZM+3.)                                               JSPLEG2.46    
      ZHLP2(JM)=1.0/SQRT(2.*ZM)                                              JSPLEG2.47    
205   CONTINUE                                                               JSPLEG2.48    
      ZHLP1(1)=SQRT(3.)                                                      JSPLEG2.49    
                                                                             JSPLEG2.50    
      DO 570 JM=1,ITOUT1                                                     JSPLEG2.51    
      I1M=JM-1                                                               JSPLEG2.52    
      ZM=I1M                                                                 JSPLEG2.53    
      ZRE1=ZHLP1(JM)                                                         JSPLEG2.54    
      ZE1=1.0/ZRE1                                                           JSPLEG2.55    
                                                                             JSPLEG2.56    
**    Step 3.       M > 0 only                                               JSPLEG2.57    
      IF (I1M.NE.0) THEN                                                     JSPLEG2.58    
         ZF2M=ZF1M*ZCOS*ZHLP2(JM)                                            JSPLEG2.59    
         ZF1M=ZF2M*ZRE1                                                      JSPLEG2.60    
                                                                             JSPLEG2.61    
**    Step 4.       N = M and N = M+1                                        JSPLEG2.62    
         ILM=ILM+1                                                           JSPLEG2.63    
         PLEG(ILM)=ZF2M                                                      JSPLEG2.64    
         ILM=ILM+1                                                           JSPLEG2.65    
         PLEG(ILM)=ZF1M*ZSIN                                                 JSPLEG2.66    
                                                                             JSPLEG2.67    
**       When output truncation is reached, return to calling program        JSPLEG2.68    
         IF (JM.EQ.ITOUT1) GOTO 570                                          JSPLEG2.69    
      ENDIF                                                                  JSPLEG2.70    
                                                                             JSPLEG2.71    
**    Step 5.       Sum for N = M+2 to T+1                                   JSPLEG2.72    
      IM2=I1M+2                                                              JSPLEG2.73    
      DO 520 JCN=IM2,ITOUT1                                                  JSPLEG2.74    
      ZN=JCN                                                                 JSPLEG2.75    
      ZHLP3(JCN)=SQRT((4.*ZN*ZN-1.)/(ZN*ZN-ZM*ZM))                           JSPLEG2.76    
520   CONTINUE                                                               JSPLEG2.77    
                                                                             JSPLEG2.78    
      DO 560 JCN=IM2,ITOUT1                                                  JSPLEG2.79    
      ZE2=ZHLP3(JCN)                                                         JSPLEG2.80    
      ILM=ILM+1                                                              JSPLEG2.81    
      PLEG(ILM)=ZE2*(ZSIN*PLEG(ILM-1)-ZE1*PLEG(ILM-2))                       JSPLEG2.82    
      ZE2=1./ZE2                                                             JSPLEG2.83    
      ZE1=ZE2                                                                JSPLEG2.84    
560   CONTINUE                                                               JSPLEG2.85    
                                                                             JSPLEG2.86    
570   CONTINUE                                                               JSPLEG2.87    
C                                                                            JSPLEG2.88    
      RETURN                                                                 JSPLEG2.89    
      END                                                                    JSPLEG2.90    
C     ***********************************************************            JSPLEG2.91    
      SUBROUTINE LTIEC                                                       LTIEC.2     
C                                                                            LTIEC.3     
C     Inverse Legendre transforms from spectral to Fourier space.            LTIEC.4     
C                                                                            LTIEC.5     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM           PARAMX.2     
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)                             PARAMX.3     
C                                                                            PARAMX.4     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/RESPECTR/RZ(JPFLSH,NL),RD(JPFLSH,NL),RT(JPFLSH,NL)              RESPECTR.2     
     :,RQ(JPFLSH,NL),RSP(JPFLSH)                                             RESPECTR.3     
C                                                                            RESPECTR.4     
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/POLYNO/POLYF(NWJ2,NHEM),CMPA(IGL)                               POLYNO.2     
      COMPLEX CMPA                                                           POLYNO.3     
C                                                                            POLYNO.4     
      COMPLEX CUG(IGK),CVG(IGK),CSFG(IGK)                                    LTIEC.14    
     :,CTG(IGK),CPMG(IGL),CPLG(IGL)                                          LTIEC.15    
     :,CSDOTG(IGK),CTXG(IGK)                                                 LTIEC.16    
      EQUIVALENCE (CUG(1),UG(1)),(CVG(1),VG(1)),(CSFG(1),THG(1))             LTIEC.17    
     :,(CSDOTG(1),SDOTG(1)),(CTG(1),TG(1)),(CTXG(1),TXG(1))                  LTIEC.18    
     :,(CPMG(1),PMG(1)),(CPLG(1),PLG(1))                                     LTIEC.19    
C                                                                            LTIEC.20    
C     Wind components.  Calls to HEXPEC give following Fourier fields:       LTIEC.21    
C        UG   :   -U(rot).                                                   LTIEC.22    
C        VG   :   V(div).                                                    LTIEC.23    
C        THG  :   streamfunction.      (Temporary - overwritten below)       LTIEC.24    
C        SDOTG:   velocity-potential.             " "                        LTIEC.25    
C     Then sum to give total winds.  CMPA takes x-derivative.                LTIEC.26    
C                                                                            LTIEC.27    
      CALL HEXPEC(RZ,UG,NL,4)                                                LTIEC.28    
      CALL HEXPEC(RZ,THG,NL,3)                                               LTIEC.29    
      CALL HEXPEC(RD,SDOTG,NL,3)                                             LTIEC.30    
      CALL HEXPEC(RD,VG,NL,4)                                                LTIEC.31    
      II=0                                                                   LTIEC.32    
      DO 20 L=1,NL                                                           LTIEC.33    
         DO 22 I=1,IGL                                                       LTIEC.34    
            II=II+1                                                          LTIEC.35    
            CUG(II)=CSDOTG(II)*CMPA(I)-CUG(II)                               LTIEC.36    
            CVG(II)=CSFG(II)*CMPA(I)+CVG(II)                                 LTIEC.37    
 22      CONTINUE                                                            LTIEC.38    
 20   CONTINUE                                                               LTIEC.39    
C                                                                            LTIEC.40    
C     Fields used to obtain vertical velocity.                               LTIEC.41    
C                                                                            LTIEC.42    
      CALL HEXPEC(RD,DG,NL,1)                                                LTIEC.43    
      CALL HEXPEC(RSP,PLG,1,1)                                               LTIEC.44    
      CALL HEXPEC(RSP,PJG,1,2)                                               LTIEC.45    
      DO 35 I=1,IGL                                                          LTIEC.46    
         CPMG(I)=CPLG(I)*CMPA(I)                                             LTIEC.47    
 35   CONTINUE                                                               LTIEC.48    
C                                                                            LTIEC.49    
C     Temperature, humidity and fields for PV calculation.                   LTIEC.50    
C                                                                            LTIEC.51    
      IF (LTATTR) CALL HEXPEC(RT,TG,NL,1)                                    LTIEC.52    
      IF (LQATTR.AND.(.NOT.LGPQ)) CALL HEXPEC(RQ,QG,NL,1)                    LTIEC.53    
      IF (LPVATTR) THEN                                                      LTIEC.54    
         CALL HEXPEC(RT,TYG,NL,2)                                            LTIEC.55    
         II=0                                                                LTIEC.56    
         DO 36 L=1,NL                                                        LTIEC.57    
            DO 37 I=1,IGL                                                    LTIEC.58    
               II=II+1                                                       LTIEC.59    
               CTXG(II)=CTG(II)*CMPA(I)                                      LTIEC.60    
 37         CONTINUE                                                         LTIEC.61    
 36      CONTINUE                                                            LTIEC.62    
C                                                                            LTIEC.63    
C     Add planetary vorticity to give absolute vorticity.                    LTIEC.64    
C                                                                            LTIEC.65    
         DO 40 L=1,NL                                                        LTIEC.66    
            RZ(3,L)=RZ(3,L)+EZR                                              LTIEC.67    
 40      CONTINUE                                                            LTIEC.68    
         CALL HEXPEC(RZ,ZG,NL,1)                                             LTIEC.69    
         DO 42 L=1,NL                                                        LTIEC.70    
            RZ(3,L)=RZ(3,L)-EZR                                              LTIEC.71    
 42      CONTINUE                                                            LTIEC.72    
      ENDIF                                                                  LTIEC.73    
C                                                                            LTIEC.74    
      RETURN                                                                 LTIEC.75    
      END                                                                    LTIEC.76    
C     **********************************************************             LTIEC.77    
      SUBROUTINE HEXPEC(SV,GV,NLS,ITYPE)                                     HEXPEC.2     
C                                                                            HEXPEC.3     
C     Performs indirect Legendre transform for a (set of) field(s)           HEXPEC.4     
C     having a total of NLS levels, from spectral to Fourier space.          HEXPEC.5     
C     The type of function and thence of transform is chosen by ITYPE        HEXPEC.6     
C     with the following currently defined:                                  HEXPEC.7     
C        ITYPE=1   :   ALEG     :   normal transform.                        HEXPEC.8     
C        ITYPE=2   :   DYLEG    :   y-derivative.                            HEXPEC.9     
C        ITYPE=3   :   DM2LEG   :   del(-2).                                 HEXPEC.10    
C        ITYPE=4   :   DYDM2LEG :   y-derivative of del(-2).                 HEXPEC.11    
C                                                                            HEXPEC.12    
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM           PARAMX.2     
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)                             PARAMX.3     
C                                                                            PARAMX.4     
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/LEGAUGS/                                                        LEGAUGS.2     
     : ALEG(JLEGP),DYLEG(JLEGP),DM2LEG(JLEGP),DYDM2LEG(JLEGP)                LEGAUGS.3     
C     *****************************************************************      LEGAUGS.4     
      DIMENSION SV(JPFLSH,NLS),ZSEC4(JPFLSH)                                 HEXPEC.18    
      DIMENSION GV(IGC,NLS),ZFA(MGPP,2),PLEG(JLEGP)                          HEXPEC.19    
      INTEGER ISYM                                                           HEXPEC.20    
C                                                                            HEXPEC.21    
      IF (ITYPE.EQ.1) THEN                                                   HEXPEC.22    
         ISYM=1                                                              HEXPEC.23    
         DO 10 I=1,JLEGP                                                     HEXPEC.24    
            PLEG(I)=ALEG(I)                                                  HEXPEC.25    
 10      CONTINUE                                                            HEXPEC.26    
      ENDIF                                                                  HEXPEC.27    
      IF (ITYPE.EQ.2) THEN                                                   HEXPEC.28    
         ISYM=-1                                                             HEXPEC.29    
         DO 12 I=1,JLEGP                                                     HEXPEC.30    
            PLEG(I)=DYLEG(I)                                                 HEXPEC.31    
 12      CONTINUE                                                            HEXPEC.32    
      ENDIF                                                                  HEXPEC.33    
      IF (ITYPE.EQ.3) THEN                                                   HEXPEC.34    
         ISYM=1                                                              HEXPEC.35    
         DO 14 I=1,JLEGP                                                     HEXPEC.36    
            PLEG(I)=DM2LEG(I)                                                HEXPEC.37    
 14      CONTINUE                                                            HEXPEC.38    
      ENDIF                                                                  HEXPEC.39    
      IF (ITYPE.EQ.4) THEN                                                   HEXPEC.40    
         ISYM=-1                                                             HEXPEC.41    
         DO 16 I=1,JLEGP                                                     HEXPEC.42    
            PLEG(I)=DYDM2LEG(I)                                              HEXPEC.43    
 16      CONTINUE                                                            HEXPEC.44    
      ENDIF                                                                  HEXPEC.45    
C                                                                            HEXPEC.46    
      IGROUP=1                                                               HEXPEC.47    
      I2=2*IGROUP                                                            HEXPEC.48    
      DO 100 L=1,NLS                                                         HEXPEC.49    
         DO 110 I=1,JPFLSH                                                   HEXPEC.50    
            ZSEC4(I)=SV(I,L)                                                 HEXPEC.51    
 110     CONTINUE                                                            HEXPEC.52    
         CALL JSYMGG(ZSEC4,PLEG,ISYM,ZFA)                                    HEXPEC.53    
         II=0                                                                HEXPEC.54    
         DO 120 IHEM=1,I2                                                    HEXPEC.55    
            DO 122 I=1,MGPP                                                  HEXPEC.56    
               II=II+1                                                       HEXPEC.57    
               GV(II,L)=ZFA(I,IHEM)                                          HEXPEC.58    
 122        CONTINUE                                                         HEXPEC.59    
 120     CONTINUE                                                            HEXPEC.60    
 100  CONTINUE                                                               HEXPEC.61    
C                                                                            HEXPEC.62    
      RETURN                                                                 HEXPEC.63    
      END                                                                    HEXPEC.64    
C     ***************************************************************        HEXPEC.65    
      SUBROUTINE JSYMGG(PSHUP,PLEG,ISYM,PZFA)                                JSYMGG.2     
**    Function - calculate gridpoint data                                    JSYMGG.3     
**    Args in -                                                              JSYMGG.4     
**               PSHUP   - Spherical harmonics field, unpacked               JSYMGG.5     
**    Args out -                                                             JSYMGG.6     
**               PZFA    - Output grid point field; contains                 JSYMGG.7     
**                         North and South latitude rows                     JSYMGG.8     
**                         symmetrically.                                    JSYMGG.9     
**    Args for work -                                                        JSYMGG.10    
**               PLEG    - Array used to hold Legendre function              JSYMGG.11    
**               ISYM    - Symmetry of Legendre function                     JSYMGG.12    
**    Com used - none                                                        JSYMGG.13    
**    Com changed - none                                                     JSYMGG.14    
**    Params used - none                                                     JSYMGG.15    
**    Called by - OPTION3                                                    JSYMGG.16    
**    Calls - CSUM                                                           JSYMGG.17    
**    Files read - none                                                      JSYMGG.18    
**    Files written - none                                                   JSYMGG.19    
**    Author - R Brugge, University of Reading, based on code by             JSYMGG.20    
**          J D Chambers, ECMWF                                              JSYMGG.21    
C                                                                            JSYMGG.22    
C     Heavily modified for 'offline' by J Methven, Reading.                  JSYMGG.23    
C     Only does calculation for one latitude pair.                           JSYMGG.24    
C     Only the wave to Fourier space transforms are performed here,          JSYMGG.25    
C     not the FFT's from Fourier space to grid.                              JSYMGG.26    
C                                                                            JSYMGG.27    
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM           PARAMX.2     
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)                             PARAMX.3     
C                                                                            PARAMX.4     
      COMPLEX PSHUP                                                          JSYMGG.31    
      DIMENSION PSHUP(JPNECS)                                                JSYMGG.32    
      REAL PLEG(JLEGP),PZFA(MGPP,2)                                          JSYMGG.33    
C                                                                            JSYMGG.34    
      INTEGER ILIM,IMLIM                                                     JSYMGG.35    
      INTEGER ITAL,ITALA,ITALS,IMN,IMP                                       JSYMGG.36    
      INTEGER ISYM,INORTH,ISOUTH                                             JSYMGG.37    
      INTEGER JM,J242,JF                                                     JSYMGG.38    
C                                                                            JSYMGG.39    
      COMPLEX ZDUM(NN+1)                                                     JSYMGG.40    
      COMPLEX ZSUMS(NN+1),ZSUMA(NN+1)                                        JSYMGG.41    
C                                                                            JSYMGG.42    
      EXTERNAL CSUM                                                          JSYMGG.43    
      COMPLEX  CSUM                                                          JSYMGG.44    
C                                                                            JSYMGG.45    
      ILIM=NN+1                                                              JSYMGG.46    
      IMLIM=MM+1                                                             JSYMGG.47    
      INORTH=1                                                               JSYMGG.48    
      ISOUTH=2                                                               JSYMGG.49    
C                                                                            JSYMGG.50    
C     Clear unused elements in array.                                        JSYMGG.51    
C                                                                            JSYMGG.52    
      DO 241 JF=2*IMLIM+1,MGPP                                               JSYMGG.53    
         PZFA(JF,INORTH)=0.0                                                 JSYMGG.54    
         PZFA(JF,ISOUTH)=0.0                                                 JSYMGG.55    
 241  CONTINUE                                                               JSYMGG.56    
C                                                                            JSYMGG.57    
C     The north and corresponding south latitude row are                     JSYMGG.58    
C     calculated at the same time from the same entry in the                 JSYMGG.59    
C     legendre function file.                                                JSYMGG.60    
C                                                                            JSYMGG.61    
      IMN = 0                                                                JSYMGG.62    
      IMP = 0                                                                JSYMGG.63    
      DO 244 JM=1,IMLIM                                                      JSYMGG.64    
         ITAL=ILIM-JM+1                                                      JSYMGG.65    
         DO 242 J242=1,ITAL                                                  JSYMGG.66    
            ZDUM(J242)=PLEG(IMP+J242)*PSHUP(IMN+J242)                        JSYMGG.67    
 242     CONTINUE                                                            JSYMGG.68    
         IMP=IMP+ITAL+1                                                      JSYMGG.69    
         IMN=IMN+ITAL                                                        JSYMGG.70    
         ITALS=(ITAL+1)/2                                                    JSYMGG.71    
         ITALA=ITAL/2                                                        JSYMGG.72    
         ZSUMS(JM)=CSUM(ITALS,ZDUM,2)                                        JSYMGG.73    
         ZSUMA(JM)=CSUM(ITALA,ZDUM(2),2)                                     JSYMGG.74    
 244  CONTINUE                                                               JSYMGG.75    
                                                                             JSYMGG.76    
**    For the southern hemisphere row, the legendre functions are            JSYMGG.77    
**    the complex conjugates of the corresponding northern row -             JSYMGG.78    
**    hence the juggling with the signs in the next loop.                    JSYMGG.79    
                                                                             JSYMGG.80    
**    Note that PZFA is REAL, but the coefficients being calculated          JSYMGG.81    
**    are COMPLEX.  There are pairs of values for each coefficient           JSYMGG.82    
**    (real and imaginary parts) and pairs of values for each                JSYMGG.83    
**    latitude (north and south).                                            JSYMGG.84    
                                                                             JSYMGG.85    
      DO 246 JM=1,IMLIM                                                      JSYMGG.86    
         PZFA(2*JM-1,INORTH)=REAL(ZSUMS(JM))+REAL(ZSUMA(JM))                 JSYMGG.87    
         PZFA(2*JM,INORTH)=AIMAG(ZSUMS(JM))+AIMAG(ZSUMA(JM))                 JSYMGG.88    
         PZFA(2*JM-1,ISOUTH)=ISYM*(REAL(ZSUMS(JM))-REAL(ZSUMA(JM)))          JSYMGG.89    
         PZFA(2*JM,ISOUTH)=ISYM*(AIMAG(ZSUMS(JM))-AIMAG(ZSUMA(JM)))          JSYMGG.90    
 246  CONTINUE                                                               JSYMGG.91    
C                                                                            JSYMGG.92    
      RETURN                                                                 JSYMGG.93    
      END                                                                    JSYMGG.94    
C     ***********************************************************            JSYMGG.95    
      COMPLEX FUNCTION CSUM(KN,UVEC,KNCX)                                    CSUM.2     
**    Function - replacement for BLAS routine CSUM - compute the             CSUM.3     
**          complex sum of a complex vector                                  CSUM.4     
**    Args in -                                                              CSUM.5     
**               KN      - Number of elements in vector                      CSUM.6     
**               UVEC    - Complex vector to be summed                       CSUM.7     
**               KNCX    - Skip distance between elementx in UVEC            CSUM.8     
**    Args out -                                                             CSUM.9     
**               CSUM    - Complex sum                                       CSUM.10    
**    Args for work - none                                                   CSUM.11    
**    Com used - none                                                        CSUM.12    
**    Com changed - none                                                     CSUM.13    
**    Params used - none                                                     CSUM.14    
**    Called by - JSYMGG                                                     CSUM.15    
**    Calls - none                                                           CSUM.16    
**    Files read - none                                                      CSUM.17    
**    Files written - none                                                   CSUM.18    
**    Author - R Brugge, University of Reading                               CSUM.19    
                                                                             CSUM.20    
      INTEGER KN, KNCX                                                       CSUM.21    
      COMPLEX UVEC (*)                                                       CSUM.22    
C     COMPLEX UVEC (214)                                                     CSUM.23    
      INTEGER IP                                                             CSUM.24    
      COMPLEX CHOLD                                                          CSUM.25    
                                                                             CSUM.26    
      CHOLD = (0.0, 0.0)                                                     CSUM.27    
                                                                             CSUM.28    
      DO 110 IP=0,KN -1                                                      CSUM.29    
      CHOLD=CHOLD+UVEC(1+IP*KNCX)                                            CSUM.30    
110   CONTINUE                                                               CSUM.31    
                                                                             CSUM.32    
      CSUM = CHOLD                                                           CSUM.33    
                                                                             CSUM.34    
      RETURN                                                                 CSUM.35    
      END                                                                    CSUM.36    
C                                                                            CSUM.37    
C     ***************************************************************        CSUM.38    
      SUBROUTINE READEC                                                      READEC.2     
C                                                                            READEC.3     
C     Read regularly gridded lat-lon data from GRIB files.                   READEC.4     
C     The data is expected to be on pressure levels.                         READEC.5     
C                                                                            READEC.6     
C     Adapted from R.Brugge's Package X.                                     READEC.7     
C                                                                            READEC.8     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM           PARAMX.2     
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)                             PARAMX.3     
C                                                                            PARAMX.4     
      INTEGER JPACK                                                          PARAMG.2     
      PARAMETER(JPSEC0=2,JPSEC1=1024,JPSEC2=1024,JPSEC3=2,JPSEC4=512,        BUGS3EC.1     
     -      JPZ2=12+2*NL,JPZ3=2,JPACK=560000)                                BUGS3EC.2     
C-----------------------------------------------------------------------     PARAMG.5     
C     LIMITS ON GRIB PARAMETERS                                              PARAMG.6     
C                                                                            PARAMG.7     
C     NAME    MEANING                                                        PARAMG.8     
C     ----    -------                                                        PARAMG.9     
C     JPSEC0  Maximum size for ISEC0                                         PARAMG.10    
C     JPSEC1  Maximum size for ISEC1                                         PARAMG.11    
C     JPSEC2  Maximum size for ISEC2                                         PARAMG.12    
C     JPSEC3  Maximum size for ISEC3                                         PARAMG.13    
C     JPSEC4  Maximum size for ISEC4                                         PARAMG.14    
C     JPZ2    Maximum size for ZSEC2                                         PARAMG.15    
C     JPZ3    Maximum size for ZSEC3                                         PARAMG.16    
C     JPACK=280000 is large enough for T213 data                             PARAMG.17    
C-----------------------------------------------------------------------     PARAMG.18    
C                                                                            PARAMG.19    
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)                                       COMPSG.2     
C      PARAMETER(IGDLAP=1,IGCP=IGC)                                          COMPSG.3     
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)             COMPSG.4     
     :,BLETAM(IGCP,JG)                                                       SFCDATA.14    
C                                                                            COMPSG.5     
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/LEGAU/                                                          LEGAU.2     
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)       LEGAU.3     
     :,JH,JL                                                                 LEGAU.4     
C                                                                            LEGAU.5     
C                                                                            READEC.19    
      PARAMETER(JLATS=2*(JG+1)+1,ILEN4=MG*JLATS)                             READEC.20    
      INTEGER IREC,IREM,INPFEND,IFIELD,KLEV,ISTAT                            Y2K.163   
      DIMENSION ZSEC4(ILEN4)                                                 READEC.22    
      DIMENSION ZGR(MG,JLATS,NL),TGR(MG,JLATS,NL),UGR(MG,JLATS,NL)           READEC.23    
     :   ,VGR(MG,JLATS,NL),OMGR(MG,JLATS,NL),QGR(MG,JLATS,NL)                READEC.24    
C                                                                            Y2K.164   
C     Determine channel for required GRIB spectral file.                     Y2K.165   
C     Find filename for channel.                                             Y2K.166   
C                                                                            Y2K.167   
      IREC=NINT((DAY-BEGDAY)/THIST)                                          Y2K.168   
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)                                   Y2K.169   
      INPFEND=IOFFSET+7                                                      Y2K.170   
      IF (ISYY.GT.99) INPFEND=IOFFSET+9                                      Y2K.171   
      IF (IREM.EQ.0) THEN                                                    Y2K.172   
         CALL MAKENAME(FSTEM,IOFFSET,INPFNAME,NCDATE,LGPQ)                   Y2K.173   
         WRITE(LOUTP,*) 'Assuming file ',INPFNAME(1:INPFEND)                 Y2K.174   
     :        ,' is Cray unblocked'                                          Y2K.175   
         ISTAT=0                                                             Y2K.176   
C                                                                            Y2K.177   
C     Note that PBOPEN will change the channel number INPUT.                 Y2K.178   
C                                                                            Y2K.179   
         CALL PBOPEN(INPUT,INPFNAME(1:INPFEND),'r',ISTAT)                    Y2K.180   
         IF(ISTAT.NE.0) THEN                                                 Y2K.181   
            WRITE(LOUTP,*) 'Error opening file ',INPFNAME(1:INPFEND)         Y2K.182   
            WRITE(LOUTP,*) 'PBOPEN returns ISTAT = ',ISTAT                   Y2K.183   
            WRITE(LOUTP,*) 'Called from READEC'                              Y2K.184   
            CALL ABORT                                                       Y2K.185   
         ELSE                                                                Y2K.186   
            PRINT *,INPFNAME(1:INPFEND),' OPENED'                            Y2K.187   
         ENDIF                                                               Y2K.188   
      ENDIF                                                                  Y2K.189   
C                                                                            READEC.47    
C     Loop over variables Z,T,U,V,Q,W for all levels.                        READEC.48    
C     NOTE: these records contain relative humidity.                         READEC.49    
C                                                                            READEC.50    
      DO 285 L=1,NL                                                          READEC.51    
         DO 290 IVAR=1,6                                                     READEC.52    
            IFIELD=0                                                         Y2K.190   
            CALL SPUNPACK(ZSEC4,ILEN4,INPUT,IFIELD,KLEV)                     Y2K.191   
            IF (IFIELD.EQ.129) THEN                                          READEC.54    
               II=0                                                          READEC.55    
               DO 200 J=1,JLATS                                              READEC.56    
                  DO 205 I=1,MG                                              READEC.57    
                     II=II+1                                                 READEC.58    
                     ZGR(I,J,L)=ZSEC4(II)                                    READEC.59    
 205              CONTINUE                                                   READEC.60    
 200           CONTINUE                                                      READEC.61    
            ENDIF                                                            READEC.62    
            IF (IFIELD.EQ.130) THEN                                          READEC.63    
               II=0                                                          READEC.64    
               DO 210 J=1,JLATS                                              READEC.65    
                  DO 215 I=1,MG                                              READEC.66    
                     II=II+1                                                 READEC.67    
                     TGR(I,J,L)=ZSEC4(II)                                    READEC.68    
 215              CONTINUE                                                   READEC.69    
 210           CONTINUE                                                      READEC.70    
            ENDIF                                                            READEC.71    
            IF (IFIELD.EQ.131) THEN                                          READEC.72    
               II=0                                                          READEC.73    
               DO 220 J=1,JLATS                                              READEC.74    
                  DO 225 I=1,MG                                              READEC.75    
                     II=II+1                                                 READEC.76    
                     UGR(I,J,L)=ZSEC4(II)                                    READEC.77    
 225              CONTINUE                                                   READEC.78    
 220           CONTINUE                                                      READEC.79    
            ENDIF                                                            READEC.80    
            IF (IFIELD.EQ.132) THEN                                          READEC.81    
               II=0                                                          READEC.82    
               DO 230 J=1,JLATS                                              READEC.83    
                  DO 235 I=1,MG                                              READEC.84    
                     II=II+1                                                 READEC.85    
                     VGR(I,J,L)=ZSEC4(II)                                    READEC.86    
 235              CONTINUE                                                   READEC.87    
 230           CONTINUE                                                      READEC.88    
            ENDIF                                                            READEC.89    
            IF (IFIELD.EQ.157) THEN                                          READEC.90    
               II=0                                                          READEC.91    
               DO 240 J=1,JLATS                                              READEC.92    
                  DO 245 I=1,MG                                              READEC.93    
                     II=II+1                                                 READEC.94    
                     QGR(I,J,L)=ZSEC4(II)                                    READEC.95    
 245              CONTINUE                                                   READEC.96    
 240           CONTINUE                                                      READEC.97    
            ENDIF                                                            READEC.98    
            IF (IFIELD.EQ.135) THEN                                          READEC.99    
               II=0                                                          READEC.100   
               DO 250 J=1,JLATS                                              READEC.101   
                  DO 255 I=1,MG                                              READEC.102   
                     II=II+1                                                 READEC.103   
                     OMGR(I,J,L)=ZSEC4(II)                                   READEC.104   
 255              CONTINUE                                                   READEC.105   
 250           CONTINUE                                                      READEC.106   
            ENDIF                                                            READEC.107   
 290     CONTINUE                                                            READEC.108   
 285  CONTINUE                                                               READEC.109   
C                                                                            READEC.110   
C     Close input file.                                                      READEC.111   
C                                                                            READEC.112   
      IF (IREM.EQ.0) THEN                                                    READEC.113   
         ISTAT=0                                                             READEC.114   
         CALL PBCLOSE(INPUT,ISTAT)                                           READEC.115   
         IF(ISTAT.NE.0) THEN                                                 READEC.116   
            WRITE(LOUTP,*) 'ERROR CLOSING FILE ',INPFNAME(1:INPFEND)         Y2K.192   
            WRITE(LOUTP,*) 'ISTAT = ',ISTAT                                  READEC.118   
            CALL ABORT                                                       READEC.119   
         ENDIF                                                               READEC.120   
      ENDIF                                                                  READEC.121   
C                                                                            READEC.128   
C     Loop over latitude for grid point calculations and                     READEC.129   
C     writing to attribute files.                                            READEC.130   
C                                                                            READEC.131   
      INORTH=0                                                               READEC.132   
      ISOUTH=MGPP                                                            READEC.133   
      JL=1                                                                   READEC.134   
      DO 1000 J=1,JG                                                         READEC.135   
C                                                                            READEC.136   
C     Miss out grid points at poles and equator.                             READEC.137   
C     PSGLA contains geopotential height for testing whether                 READEC.138   
C     below ground or not.                                                   READEC.139   
C                                                                            READEC.140   
         KK=(JL-1)*IGD                                                       READEC.141   
         JSOUTH=JGGP-J                                                       READEC.142   
         DO 305 L=1,NL                                                       READEC.143   
            LL=(L-1)*IGC                                                     READEC.144   
            DO 310 I=1,MG                                                    READEC.145   
               URHS(KK+LL+INORTH+I)=UGR(I,J+1,L)                             READEC.146   
     :              *86400./(RADEA*CS(J))                                    READEC.147   
               URHS(KK+LL+ISOUTH+I)=UGR(I,JSOUTH+2,L)                        READEC.148   
     :              *86400./(RADEA*CS(JSOUTH))                               READEC.149   
               VRHS(KK+LL+INORTH+I)=VGR(I,J+1,L)                             READEC.150   
     :              *86400./RADEA                                            READEC.151   
               VRHS(KK+LL+ISOUTH+I)=VGR(I,JSOUTH+2,L)                        READEC.152   
     :              *86400./RADEA                                            READEC.153   
               SDRHS(KK+LL+INORTH+I)=OMGR(I,J+1,L)                           READEC.154   
     :              *86400./P0                                               READEC.155   
               SDRHS(KK+LL+ISOUTH+I)=OMGR(I,JSOUTH+2,L)                      READEC.156   
     :              *86400./P0                                               READEC.157   
               PSGLA(KK+LL+INORTH+I)=ZGR(I,J+1,L)                            READEC.158   
               PSGLA(KK+LL+ISOUTH+I)=ZGR(I,JSOUTH+2,L)                       READEC.159   
               THGLA(KK+LL+INORTH+I)=TGR(I,J+1,L)                            READEC.160   
               THGLA(KK+LL+ISOUTH+I)=TGR(I,JSOUTH+2,L)                       READEC.161   
               QG(LL+INORTH+I)=QGR(I,J+1,L)                                  READEC.162   
               QG(LL+ISOUTH+I)=QGR(I,JSOUTH+2,L)                             READEC.163   
 310        CONTINUE                                                         READEC.164   
 305     CONTINUE                                                            READEC.165   
C                                                                            READEC.166   
C     Write attribute files.                                                 READEC.167   
C                                                                            READEC.168   
         DO 430 L=1,NL                                                       READEC.169   
            LL=(L-1)*IGC                                                     READEC.170   
            DO 435 I=1,IGC                                                   READEC.171   
               TG(LL+I)=THGLA(KK+LL+I)                                       READEC.172   
               THGLA(KK+LL+I)=THGLA(KK+LL+I)*(ALEV(L)**(-AKAP))              READEC.173   
               THG(LL+I)=THGLA(KK+LL+I)                                      READEC.174   
 435        CONTINUE                                                         READEC.175   
 430     CONTINUE                                                            READEC.176   
         IF (NATTR.GT.0) THEN                                                READEC.177   
            WRITE(NCGP(1)) TG                                                READEC.178   
            WRITE(NCGP(2)) THG                                               READEC.179   
            WRITE(NCGP(4)) QG                                                READEC.180   
         ENDIF                                                               READEC.181   
C                                                                            READEC.182   
         JL=JL+1                                                             READEC.183   
 1000 CONTINUE                                                               READEC.184   
C                                                                            READEC.185   
      RETURN                                                                 READEC.186   
      END                                                                    READEC.187   
C     ***************************************************************        READEC.188   
      SUBROUTINE READOROG                                                    READOROG.2     
C                                                                            READOROG.3     
C     Read regularly gridded lat-lon OROGRAPHY from GRIB files               READOROG.4     
C     and place in PLGLA array.                                              READOROG.5     
C                                                                            READOROG.6     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM           PARAMX.2     
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)                             PARAMX.3     
C                                                                            PARAMX.4     
      INTEGER JPACK                                                          PARAMG.2     
      PARAMETER(JPSEC0=2,JPSEC1=1024,JPSEC2=1024,JPSEC3=2,JPSEC4=512,        BUGS3EC.1     
     -      JPZ2=12+2*NL,JPZ3=2,JPACK=560000)                                BUGS3EC.2     
C-----------------------------------------------------------------------     PARAMG.5     
C     LIMITS ON GRIB PARAMETERS                                              PARAMG.6     
C                                                                            PARAMG.7     
C     NAME    MEANING                                                        PARAMG.8     
C     ----    -------                                                        PARAMG.9     
C     JPSEC0  Maximum size for ISEC0                                         PARAMG.10    
C     JPSEC1  Maximum size for ISEC1                                         PARAMG.11    
C     JPSEC2  Maximum size for ISEC2                                         PARAMG.12    
C     JPSEC3  Maximum size for ISEC3                                         PARAMG.13    
C     JPSEC4  Maximum size for ISEC4                                         PARAMG.14    
C     JPZ2    Maximum size for ZSEC2                                         PARAMG.15    
C     JPZ3    Maximum size for ZSEC3                                         PARAMG.16    
C     JPACK=280000 is large enough for T213 data                             PARAMG.17    
C-----------------------------------------------------------------------     PARAMG.18    
C                                                                            PARAMG.19    
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)                                       COMPSG.2     
C      PARAMETER(IGDLAP=1,IGCP=IGC)                                          COMPSG.3     
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)             COMPSG.4     
     :,BLETAM(IGCP,JG)                                                       SFCDATA.14    
C                                                                            COMPSG.5     
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/LEGAU/                                                          LEGAU.2     
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)       LEGAU.3     
     :,JH,JL                                                                 LEGAU.4     
C                                                                            LEGAU.5     
C                                                                            READOROG.17    
      PARAMETER(JLATS=2*(JG+1)+1,ILEN4=MG*JLATS)                             READOROG.18    
      INTEGER IREC,IREM,INPFEND,IFIELD,KLEV,ISTAT                            Y2K.193   
      DIMENSION ZSEC4(ILEN4)                                                 READOROG.20    
      DIMENSION OROG(MG,JLATS)                                               READOROG.21    
C                                                                            Y2K.194   
C     Determine channel for required GRIB spectral file.                     Y2K.195   
C     Find filename for channel.                                             Y2K.196   
C                                                                            Y2K.197   
      IREC=NINT((DAY-BEGDAY)/THIST)                                          Y2K.198   
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)                                   Y2K.199   
      INPFEND=IOFFSET+7                                                      Y2K.200   
      IF (ISYY.GT.99) INPFEND=IOFFSET+9                                      Y2K.201   
      IF (IREM.EQ.0) THEN                                                    Y2K.202   
         CALL MAKENAME(FSTEM2,IOFFSET,INPFNAME,NCDATE,LGPQ)                  Y2K.203   
         WRITE(LOUTP,*) 'Assuming file ',INPFNAME(1:INPFEND)                 Y2K.204   
     :        ,' is Cray unblocked'                                          Y2K.205   
         ISTAT=0                                                             Y2K.206   
C                                                                            Y2K.207   
C     Note that PBOPEN will change the channel number INPUT.                 Y2K.208   
C                                                                            Y2K.209   
         CALL PBOPEN(INPUT2,INPFNAME(1:INPFEND),'r',ISTAT)                   Y2K.210   
         IF(ISTAT.NE.0) THEN                                                 Y2K.211   
            WRITE(LOUTP,*) 'Error opening file ',INPFNAME(1:INPFEND)         Y2K.212   
            WRITE(LOUTP,*) 'PBOPEN returns ISTAT = ',ISTAT                   Y2K.213   
            WRITE(LOUTP,*) 'Called from READOROG'                            Y2K.214   
            CALL ABORT                                                       Y2K.215   
         ELSE                                                                Y2K.216   
            PRINT *,INPFNAME(1:INPFEND),' OPENED'                            Y2K.217   
         ENDIF                                                               Y2K.218   
      ENDIF                                                                  Y2K.219   
C                                                                            READOROG.44    
C     Read orographic height.                                                READOROG.45    
C                                                                            READOROG.46    
      IFIELD=0                                                               Y2K.220   
      CALL SPUNPACK(ZSEC4,ILEN4,INPUT2,IFIELD,KLEV)                          Y2K.221   
      IF (IFIELD.EQ.129) THEN                                                READOROG.48    
         II=0                                                                READOROG.49    
         DO 200 J=1,JLATS                                                    READOROG.50    
            DO 205 I=1,MG                                                    READOROG.51    
               II=II+1                                                       READOROG.52    
               OROG(I,J)=ZSEC4(II)                                           READOROG.53    
 205        CONTINUE                                                         READOROG.54    
 200     CONTINUE                                                            READOROG.55    
      ELSE                                                                   READOROG.56    
         WRITE(LOUTP,*) 'First field was not orographic height.'             READOROG.57    
         STOP                                                                READOROG.58    
      ENDIF                                                                  READOROG.59    
C                                                                            READOROG.60    
C     Close input file.                                                      READOROG.61    
C                                                                            READOROG.62    
      IF (IREM.EQ.0) THEN                                                    READOROG.63    
         ISTAT=0                                                             READOROG.64    
         CALL PBCLOSE(INPUT2,ISTAT)                                          READOROG.65    
         IF(ISTAT.NE.0) THEN                                                 READOROG.66    
            WRITE(LOUTP,*) 'ERROR CLOSING FILE ',INPFNAME(1:INPFEND)         Y2K.222   
            WRITE(LOUTP,*) 'ISTAT = ',ISTAT                                  READOROG.68    
            CALL ABORT                                                       READOROG.69    
         ENDIF                                                               READOROG.70    
      ENDIF                                                                  READOROG.71    
C                                                                            READOROG.72    
C     Loop over latitude for grid point calculations and                     READOROG.73    
C     writing to attribute files.                                            READOROG.74    
C                                                                            READOROG.75    
      INORTH=0                                                               READOROG.76    
      ISOUTH=MGPP                                                            READOROG.77    
      DO 1000 J=1,JG                                                         READOROG.78    
C                                                                            READOROG.79    
C     Miss out grid points at poles and equator.                             READOROG.80    
C     PLGLA contains OROGRAPHIC height for testing whether                   READOROG.81    
C     below ground or not.                                                   READOROG.82    
C                                                                            READOROG.83    
         JSOUTH=JGGP-J                                                       READOROG.84    
         DO 310 I=1,MG                                                       READOROG.85    
            PLGLA(INORTH+I,J)=OROG(I,J+1)                                    READOROG.86    
            PLGLA(ISOUTH+I,J)=OROG(I,JSOUTH+2)                               READOROG.87    
 310     CONTINUE                                                            READOROG.88    
 1000 CONTINUE                                                               READOROG.89    
C                                                                            READOROG.90    
      RETURN                                                                 READOROG.91    
      END                                                                    READOROG.92    
C     ***************************************************************        READOROG.93    
C     SUBROUTINE 'SET99' - COMPUTES FACTORS OF N & TRIGONOMETRIC             SET99.2     
C     FUNCTINS REQUIRED BY FFT991(F)                                         SET99.3     
C                                                                            SET99.4     
      SUBROUTINE SET99(TRIGS,IFAX,N)                                         SET99.5     
      DIMENSION TRIGS(N),IFAX(1),JFAX(10),LFAX(7)                            SET99.6     
      DATA LFAX/6,8,5,4,3,2,1/                                               SET99.7     
C                                                                            SET99.8     
      DEL=4.0*ASIN(1.0)/FLOAT(N)                                             SET99.9     
      NIL=0                                                                  SET99.10    
      NHL=(N/2)-1                                                            SET99.11    
      DO 10 K=NIL,NHL                                                        SET99.12    
      ANGLE=FLOAT(K)*DEL                                                     SET99.13    
      TRIGS(2*K+1)=COS(ANGLE)                                                SET99.14    
      TRIGS(2*K+2)=SIN(ANGLE)                                                SET99.15    
   10 CONTINUE                                                               SET99.16    
C                                                                            SET99.17    
C     FIND FACTORS OF N (8,6,5,4,3,2; ONLY ONE 8 ALLOWED)                    SET99.18    
C     LOOK FOR SIXES FIRST, STORE FACTORS IN DESCENDING ORDER                SET99.19    
      NU=N                                                                   SET99.20    
      IFAC=6                                                                 SET99.21    
      K=0                                                                    SET99.22    
      L=1                                                                    SET99.23    
   20 CONTINUE                                                               SET99.24    
      IF (MOD(NU,IFAC).NE.0) GO TO 30                                        SET99.25    
      K=K+1                                                                  SET99.26    
      JFAX(K)=IFAC                                                           SET99.27    
      IF (IFAC.NE.8) GO TO 25                                                SET99.28    
      IF (K.EQ.1) GO TO 25                                                   SET99.29    
      JFAX(1)=8                                                              SET99.30    
      JFAX(K)=6                                                              SET99.31    
   25 CONTINUE                                                               SET99.32    
      NU=NU/IFAC                                                             SET99.33    
      IF (NU.EQ.1) GO TO 50                                                  SET99.34    
      IF (IFAC.NE.8) GO TO 20                                                SET99.35    
   30 CONTINUE                                                               SET99.36    
      L=L+1                                                                  SET99.37    
      IFAC=LFAX(L)                                                           SET99.38    
      IF (IFAC.GT.1) GO TO 20                                                SET99.39    
C                                                                            SET99.40    
      WRITE(6,40) N                                                          SET99.41    
   40 FORMAT(4H1N =,I4,27H - CONTAINS ILLEGAL FACTORS)                       SET99.42    
      RETURN                                                                 SET99.43    
C                                                                            SET99.44    
C     NOW REVERSE ORDER OF FACTORS                                           SET99.45    
   50 CONTINUE                                                               SET99.46    
      NFAX=K                                                                 SET99.47    
      IFAX(1)=NFAX                                                           SET99.48    
      DO 60 I=1,NFAX                                                         SET99.49    
      IFAX(NFAX+2-I)=JFAX(I)                                                 SET99.50    
   60 CONTINUE                                                               SET99.51    
      RETURN                                                                 SET99.52    
      END                                                                    SET99.53    
C     ***************************************************************        SET99.54    
C     SUBROUTINE 'FFT991' - MULTIPLE FAST REAL PERIODIC TRANSFORM            FFT991F.2     
C                                                                            FFT991F.3     
C     Minor modifications - Clive Temperton, January 1991:                   FFT991F.4     
C         modified vector-chopping for better performance                    FFT991F.5     
C                                                                            FFT991F.6     
C     REAL TRANSFORM OF LENGTH N PERFORMED BY REMOVING REDUNDANT             FFT991F.7     
C     OPERATIONS FROM COMPLEX TRANSFORM OF LENGTH N                          FFT991F.8     
C                                                                            FFT991F.9     
C     A IS THE ARRAY CONTAINING INPUT & OUTPUT DATA                          FFT991F.10    
C     WORK IS AN AREA OF SIZE (N+1)*MIN(LOT,64)                              FFT991F.11    
C     TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES            FFT991F.12    
C     IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N                     FFT991F.13    
C     INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR'                         FFT991F.14    
C         (E.G. INC=1 FOR CONSECUTIVELY STORED DATA)                         FFT991F.15    
C     JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR            FFT991F.16    
C     N IS THE LENGTH OF THE DATA VECTORS                                    FFT991F.17    
C     LOT IS THE NUMBER OF DATA VECTORS                                      FFT991F.18    
C     ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT                    FFT991F.19    
C           = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL                    FFT991F.20    
C                                                                            FFT991F.21    
C     ORDERING OF COEFFICIENTS:                                              FFT991F.22    
C         A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2)                    FFT991F.23    
C         WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED                      FFT991F.24    
C                                                                            FFT991F.25    
C     ORDERING OF DATA:                                                      FFT991F.26    
C         X(0),X(1),X(2),...,X(N-1), 0 , 0 ; (N+2) LOCATIONS REQUIRED        FFT991F.27    
C                                                                            FFT991F.28    
C     VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS              FFT991F.29    
C     IN PARALLEL                                                            FFT991F.30    
C                                                                            FFT991F.31    
C     N MUST BE COMPOSED OF FACTORS 2,3 & 5 BUT DOES NOT HAVE TO BE EVEN     FFT991F.32    
C                                                                            FFT991F.33    
C     DEFINITION OF TRANSFORMS:                                              FFT991F.34    
C     -------------------------                                              FFT991F.35    
C                                                                            FFT991F.36    
C     ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N))                FFT991F.37    
C         WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K)                      FFT991F.38    
C                                                                            FFT991F.39    
C     ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N))            FFT991F.40    
C               B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N))           FFT991F.41    
C                                                                            FFT991F.42    
      SUBROUTINE FFT991(A,WORK,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN)              FFT991F.43    
      DIMENSION A(N),WORK(N),TRIGS(N),IFAX(1)                                FFT991F.44    
C                                                                            FFT991F.45    
      NFAX=IFAX(1)                                                           FFT991F.46    
      NX=N+1                                                                 FFT991F.47    
      IF (MOD(N,2).EQ.1) NX=N                                                FFT991F.48    
      NBLOX=1+(LOT-1)/64                                                     FFT991F.49    
      LEFT=LOT                                                               FFT991F.50    
      IF (ISIGN.EQ.-1) GO TO 300                                             FFT991F.51    
C                                                                            FFT991F.52    
C     ISIGN=+1, SPECTRAL TO GRIDPOINT TRANSFORM                              FFT991F.53    
C     -----------------------------------------                              FFT991F.54    
  100 CONTINUE                                                               FFT991F.55    
      ISTART=1                                                               FFT991F.56    
      DO 220 NB=1,NBLOX                                                      FFT991F.57    
      IF (LEFT.LE.64) THEN                                                   FFT991F.58    
         NVEX=LEFT                                                           FFT991F.59    
      ELSE IF (LEFT.LT.128) THEN                                             FFT991F.60    
         NVEX=LEFT/2                                                         FFT991F.61    
      ELSE                                                                   FFT991F.62    
         NVEX=64                                                             FFT991F.63    
      ENDIF                                                                  FFT991F.64    
      LEFT=LEFT-NVEX                                                         FFT991F.65    
      IA=ISTART                                                              FFT991F.66    
      I=ISTART                                                               FFT991F.67    
CDIR$ IVDEP                                                                  FFT991F.68    
      DO 110 J=1,NVEX                                                        FFT991F.69    
      A(I+INC)=0.5*A(I)                                                      FFT991F.70    
      I=I+JUMP                                                               FFT991F.71    
  110 CONTINUE                                                               FFT991F.72    
      IF (MOD(N,2).EQ.1) GO TO 130                                           FFT991F.73    
      I=ISTART+N*INC                                                         FFT991F.74    
      DO 120 J=1,NVEX                                                        FFT991F.75    
      A(I)=0.5*A(I)                                                          FFT991F.76    
      I=I+JUMP                                                               FFT991F.77    
  120 CONTINUE                                                               FFT991F.78    
  130 CONTINUE                                                               FFT991F.79    
      IA=ISTART+INC                                                          FFT991F.80    
      LA=1                                                                   FFT991F.81    
      IGO=+1                                                                 FFT991F.82    
C                                                                            FFT991F.83    
      DO 160 K=1,NFAX                                                        FFT991F.84    
      IFAC=IFAX(K+1)                                                         FFT991F.85    
      IERR=-1                                                                FFT991F.86    
      IF (IGO.EQ.-1) GO TO 140                                               FFT991F.87    
      CALL RPASSM(A(IA),A(IA+LA*INC),WORK(1),WORK(IFAC*LA+1),TRIGS,          FFT991F.88    
     *    INC,1,JUMP,NX,NVEX,N,IFAC,LA,IERR)                                 FFT991F.89    
      GO TO 150                                                              FFT991F.90    
  140 CONTINUE                                                               FFT991F.91    
      CALL RPASSM(WORK(1),WORK(LA+1),A(IA),A(IA+IFAC*LA*INC),TRIGS,          FFT991F.92    
     *    1,INC,NX,JUMP,NVEX,N,IFAC,LA,IERR)                                 FFT991F.93    
  150 CONTINUE                                                               FFT991F.94    
      IF (IERR.NE.0) GO TO 500                                               FFT991F.95    
      LA=IFAC*LA                                                             FFT991F.96    
      IGO=-IGO                                                               FFT991F.97    
      IA=ISTART                                                              FFT991F.98    
  160 CONTINUE                                                               FFT991F.99    
C                                                                            FFT991F.100   
C     IF NECESSARY, COPY RESULTS BACK TO A                                   FFT991F.101   
C     ------------------------------------                                   FFT991F.102   
      IF (MOD(NFAX,2).EQ.0) GO TO 190                                        FFT991F.103   
      IBASE=1                                                                FFT991F.104   
      JBASE=IA                                                               FFT991F.105   
      DO 180 JJ=1,NVEX                                                       FFT991F.106   
      I=IBASE                                                                FFT991F.107   
      J=JBASE                                                                FFT991F.108   
      DO 170 II=1,N                                                          FFT991F.109   
      A(J)=WORK(I)                                                           FFT991F.110   
      I=I+1                                                                  FFT991F.111   
      J=J+INC                                                                FFT991F.112   
  170 CONTINUE                                                               FFT991F.113   
      IBASE=IBASE+NX                                                         FFT991F.114   
      JBASE=JBASE+JUMP                                                       FFT991F.115   
  180 CONTINUE                                                               FFT991F.116   
  190 CONTINUE                                                               FFT991F.117   
C                                                                            FFT991F.118   
C     FILL IN ZEROS AT END                                                   FFT991F.119   
C     --------------------                                                   FFT991F.120   
      IX=ISTART+N*INC                                                        FFT991F.121   
CDIR$ IVDEP                                                                  FFT991F.122   
      DO 210 J=1,NVEX                                                        FFT991F.123   
      A(IX)=0.0                                                              FFT991F.124   
      A(IX+INC)=0.0                                                          FFT991F.125   
      IX=IX+JUMP                                                             FFT991F.126   
  210 CONTINUE                                                               FFT991F.127   
C                                                                            FFT991F.128   
      ISTART=ISTART+NVEX*JUMP                                                FFT991F.129   
  220 CONTINUE                                                               FFT991F.130   
      RETURN                                                                 FFT991F.131   
C                                                                            FFT991F.132   
C     ISIGN=-1, GRIDPOINT TO SPECTRAL TRANSFORM                              FFT991F.133   
C     -----------------------------------------                              FFT991F.134   
  300 CONTINUE                                                               FFT991F.135   
      ISTART=1                                                               FFT991F.136   
      DO 410 NB=1,NBLOX                                                      FFT991F.137   
      IF (LEFT.LE.64) THEN                                                   FFT991F.138   
         NVEX=LEFT                                                           FFT991F.139   
      ELSE IF (LEFT.LT.128) THEN                                             FFT991F.140   
         NVEX=LEFT/2                                                         FFT991F.141   
      ELSE                                                                   FFT991F.142   
         NVEX=64                                                             FFT991F.143   
      ENDIF                                                                  FFT991F.144   
      LEFT=LEFT-NVEX                                                         FFT991F.145   
      IA=ISTART                                                              FFT991F.146   
      LA=N                                                                   FFT991F.147   
      IGO=+1                                                                 FFT991F.148   
C                                                                            FFT991F.149   
      DO 340 K=1,NFAX                                                        FFT991F.150   
      IFAC=IFAX(NFAX+2-K)                                                    FFT991F.151   
      LA=LA/IFAC                                                             FFT991F.152   
      IERR=-1                                                                FFT991F.153   
      IF (IGO.EQ.-1) GO TO 320                                               FFT991F.154   
      CALL QPASSM(A(IA),A(IA+IFAC*LA*INC),WORK(1),WORK(LA+1),TRIGS,          FFT991F.155   
     *    INC,1,JUMP,NX,NVEX,N,IFAC,LA,IERR)                                 FFT991F.156   
      GO TO 330                                                              FFT991F.157   
  320 CONTINUE                                                               FFT991F.158   
      CALL QPASSM(WORK(1),WORK(IFAC*LA+1),A(IA),A(IA+LA*INC),TRIGS,          FFT991F.159   
     *    1,INC,NX,JUMP,NVEX,N,IFAC,LA,IERR)                                 FFT991F.160   
  330 CONTINUE                                                               FFT991F.161   
      IF (IERR.NE.0) GO TO 500                                               FFT991F.162   
      IGO=-IGO                                                               FFT991F.163   
      IA=ISTART+INC                                                          FFT991F.164   
  340 CONTINUE                                                               FFT991F.165   
C                                                                            FFT991F.166   
C     IF NECESSARY, COPY RESULTS BACK TO A                                   FFT991F.167   
C     ------------------------------------                                   FFT991F.168   
      IF (MOD(NFAX,2).EQ.0) GO TO 370                                        FFT991F.169   
      IBASE=1                                                                FFT991F.170   
      JBASE=IA                                                               FFT991F.171   
      DO 360 JJ=1,NVEX                                                       FFT991F.172   
      I=IBASE                                                                FFT991F.173   
      J=JBASE                                                                FFT991F.174   
      DO 350 II=1,N                                                          FFT991F.175   
      A(J)=WORK(I)                                                           FFT991F.176   
      I=I+1                                                                  FFT991F.177   
      J=J+INC                                                                FFT991F.178   
  350 CONTINUE                                                               FFT991F.179   
      IBASE=IBASE+NX                                                         FFT991F.180   
      JBASE=JBASE+JUMP                                                       FFT991F.181   
  360 CONTINUE                                                               FFT991F.182   
  370 CONTINUE                                                               FFT991F.183   
C                                                                            FFT991F.184   
C     SHIFT A(0) & FILL IN ZERO IMAG PARTS                                   FFT991F.185   
C     ------------------------------------                                   FFT991F.186   
      IX=ISTART                                                              FFT991F.187   
CDIR$ IVDEP                                                                  FFT991F.188   
      DO 380 J=1,NVEX                                                        FFT991F.189   
      A(IX)=A(IX+INC)                                                        FFT991F.190   
      A(IX+INC)=0.0                                                          FFT991F.191   
      IX=IX+JUMP                                                             FFT991F.192   
  380 CONTINUE                                                               FFT991F.193   
      IF (MOD(N,2).EQ.1) GO TO 400                                           FFT991F.194   
      IZ=ISTART+(N+1)*INC                                                    FFT991F.195   
      DO 390 J=1,NVEX                                                        FFT991F.196   
      A(IZ)=0.0                                                              FFT991F.197   
      IZ=IZ+JUMP                                                             FFT991F.198   
  390 CONTINUE                                                               FFT991F.199   
  400 CONTINUE                                                               FFT991F.200   
C                                                                            FFT991F.201   
      ISTART=ISTART+NVEX*JUMP                                                FFT991F.202   
  410 CONTINUE                                                               FFT991F.203   
      RETURN                                                                 FFT991F.204   
C                                                                            FFT991F.205   
C     ERROR MESSAGES                                                         FFT991F.206   
C     --------------                                                         FFT991F.207   
  500 CONTINUE                                                               FFT991F.208   
      GO TO (510,530,550) IERR                                               FFT991F.209   
  510 CONTINUE                                                               FFT991F.210   
      WRITE(6,520) NVEX                                                      FFT991F.211   
  520 FORMAT(16H1VECTOR LENGTH =,I4,17H, GREATER THAN 64)                    FFT991F.212   
      GO TO 570                                                              FFT991F.213   
  530 CONTINUE                                                               FFT991F.214   
      WRITE(6,540) IFAC                                                      FFT991F.215   
  540 FORMAT( 9H1FACTOR =,I3,17H, NOT CATERED FOR)                           FFT991F.216   
      GO TO 570                                                              FFT991F.217   
  550 CONTINUE                                                               FFT991F.218   
      WRITE(6,560) IFAC                                                      FFT991F.219   
  560 FORMAT(9H1FACTOR =,I3,31H, ONLY CATERED FOR IF LA*IFAC=N)              FFT991F.220   
  570 CONTINUE                                                               FFT991F.221   
      RETURN                                                                 FFT991F.222   
      END                                                                    FFT991F.223   
C     ***************************************************************        FFT991F.224   
C     SUBROUTINE 'RPASSM' - PERFORMS ONE PASS THROUGH DATA AS PART           RPASS.2     
C     OF MULTIPLE REAL FFT (FOURIER SYNTHESIS) ROUTINE                       RPASS.3     
C                                                                            RPASS.4     
C     A IS FIRST REAL INPUT VECTOR                                           RPASS.5     
C         EQUIVALENCE B(1) WITH A (LA*INC1+1)                                RPASS.6     
C     C IS FIRST REAL OUTPUT VECTOR                                          RPASS.7     
C         EQUIVALENCE D(1) WITH C(IFAC*LA*INC2+1)                            RPASS.8     
C     TRIGS IS A PRECALCULATED LIST OF SINES & COSINES                       RPASS.9     
C     INC1 IS THE ADDRESSING INCREMENT FOR A                                 RPASS.10    
C     INC2 IS THE ADDRESSING INCREMENT FOR C                                 RPASS.11    
C     INC3 IS THE INCREMENT BETWEEN INPUT VECTORS A                          RPASS.12    
C     INC4 IS THE INCREMENT BETWEEN OUTPUT VECTORS C                         RPASS.13    
C     LOT IS THE NUMBER OF VECTORS                                           RPASS.14    
C     N IS THE LENGTH OF THE VECTORS                                         RPASS.15    
C     IFAC IS THE CURRENT FACTOR OF N                                        RPASS.16    
C     LA IS THE PRODUCT OF PREVIOUS FACTORS                                  RPASS.17    
C     IERR IS AN ERROR INDICATOR:                                            RPASS.18    
C              0 - PASS COMPLETED WITHOUT ERROR                              RPASS.19    
C              1 - LOT GREATER THAN 64                                       RPASS.20    
C              2 - IFAC NOT CATERED FOR                                      RPASS.21    
C              3 - IFAC ONLY CATERED FOR IF LA=N/IFAC                        RPASS.22    
C                                                                            RPASS.23    
C-----------------------------------------------------------------------     RPASS.24    
C                                                                            RPASS.25    
      SUBROUTINE RPASSM(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC,        RPASS.26    
     *    LA,IERR)                                                           RPASS.27    
      DIMENSION A(N),B(N),C(N),D(N),TRIGS(N)                                 RPASS.28    
C                                                                            RPASS.29    
      DIMENSION A10(64),A11(64),A20(64),A21(64),                             RPASS.30    
     *    B10(64),B11(64),B20(64),B21(64)                                    RPASS.31    
      DATA SIN36/0.587785252292473/,SIN72/0.951056516295154/,                RPASS.32    
     *    QRT5/0.559016994374947/,SIN60/0.866025403784437/                   RPASS.33    
C                                                                            RPASS.34    
      M=N/IFAC                                                               RPASS.35    
      IINK=LA*INC1                                                           RPASS.36    
      JINK=LA*INC2                                                           RPASS.37    
      JUMP=(IFAC-1)*JINK                                                     RPASS.38    
      KSTOP=(N-IFAC)/(2*IFAC)                                                RPASS.39    
C                                                                            RPASS.40    
      IBAD=1                                                                 RPASS.41    
      IF (LOT.GT.64) GO TO 910                                               RPASS.42    
      IBASE=0                                                                RPASS.43    
      JBASE=0                                                                RPASS.44    
      IGO=IFAC-1                                                             RPASS.45    
      IF (IGO.EQ.7) IGO=6                                                    RPASS.46    
      IBAD=2                                                                 RPASS.47    
      IF (IGO.LT.1.OR.IGO.GT.6) GO TO 910                                    RPASS.48    
      GO TO (200,300,400,500,600,800),IGO                                    RPASS.49    
C                                                                            RPASS.50    
C     CODING FOR FACTOR 2                                                    RPASS.51    
C     -------------------                                                    RPASS.52    
  200 CONTINUE                                                               RPASS.53    
      IA=1                                                                   RPASS.54    
      IB=IA+(2*M-LA)*INC1                                                    RPASS.55    
      JA=1                                                                   RPASS.56    
      JB=JA+JINK                                                             RPASS.57    
C                                                                            RPASS.58    
      IF (LA.EQ.M) GO TO 290                                                 RPASS.59    
C                                                                            RPASS.60    
      DO 220 L=1,LA                                                          RPASS.61    
      I=IBASE                                                                RPASS.62    
      J=JBASE                                                                RPASS.63    
CDIR$ IVDEP                                                                  RPASS.64    
      DO 210 IJK=1,LOT                                                       RPASS.65    
      C(JA+J)=A(IA+I)+A(IB+I)                                                RPASS.66    
      C(JB+J)=A(IA+I)-A(IB+I)                                                RPASS.67    
      I=I+INC3                                                               RPASS.68    
      J=J+INC4                                                               RPASS.69    
  210 CONTINUE                                                               RPASS.70    
      IBASE=IBASE+INC1                                                       RPASS.71    
      JBASE=JBASE+INC2                                                       RPASS.72    
  220 CONTINUE                                                               RPASS.73    
      IA=IA+IINK                                                             RPASS.74    
      IINK=2*IINK                                                            RPASS.75    
      IB=IB-IINK                                                             RPASS.76    
      IBASE=0                                                                RPASS.77    
      JBASE=JBASE+JUMP                                                       RPASS.78    
      JUMP=2*JUMP+JINK                                                       RPASS.79    
      IF (IA.EQ.IB) GO TO 260                                                RPASS.80    
      DO 250 K=LA,KSTOP,LA                                                   RPASS.81    
      KB=K+K                                                                 RPASS.82    
      C1=TRIGS(KB+1)                                                         RPASS.83    
      S1=TRIGS(KB+2)                                                         RPASS.84    
      IBASE=0                                                                RPASS.85    
      DO 240 L=1,LA                                                          RPASS.86    
      I=IBASE                                                                RPASS.87    
      J=JBASE                                                                RPASS.88    
CDIR$ IVDEP                                                                  RPASS.89    
      DO 230 IJK=1,LOT                                                       RPASS.90    
      C(JA+J)=A(IA+I)+A(IB+I)                                                RPASS.91    
      D(JA+J)=B(IA+I)-B(IB+I)                                                RPASS.92    
      C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)+B(IB+I))                      RPASS.93    
      D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)+B(IB+I))                      RPASS.94    
      I=I+INC3                                                               RPASS.95    
      J=J+INC4                                                               RPASS.96    
  230 CONTINUE                                                               RPASS.97    
      IBASE=IBASE+INC1                                                       RPASS.98    
      JBASE=JBASE+INC2                                                       RPASS.99    
  240 CONTINUE                                                               RPASS.100   
      IA=IA+IINK                                                             RPASS.101   
      IB=IB-IINK                                                             RPASS.102   
      JBASE=JBASE+JUMP                                                       RPASS.103   
  250 CONTINUE                                                               RPASS.104   
      IF (IA.GT.IB) GO TO 900                                                RPASS.105   
  260 CONTINUE                                                               RPASS.106   
      IBASE=0                                                                RPASS.107   
      DO 280 L=1,LA                                                          RPASS.108   
      I=IBASE                                                                RPASS.109   
      J=JBASE                                                                RPASS.110   
CDIR$ IVDEP                                                                  RPASS.111   
      DO 270 IJK=1,LOT                                                       RPASS.112   
      C(JA+J)=A(IA+I)                                                        RPASS.113   
      C(JB+J)=-B(IA+I)                                                       RPASS.114   
      I=I+INC3                                                               RPASS.115   
      J=J+INC4                                                               RPASS.116   
  270 CONTINUE                                                               RPASS.117   
      IBASE=IBASE+INC1                                                       RPASS.118   
      JBASE=JBASE+INC2                                                       RPASS.119   
  280 CONTINUE                                                               RPASS.120   
      GO TO 900                                                              RPASS.121   
C                                                                            RPASS.122   
  290 CONTINUE                                                               RPASS.123   
      DO 294 L=1,LA                                                          RPASS.124   
      I=IBASE                                                                RPASS.125   
      J=JBASE                                                                RPASS.126   
CDIR$ IVDEP                                                                  RPASS.127   
      DO 292 IJK=1,LOT                                                       RPASS.128   
      C(JA+J)=2.0*(A(IA+I)+A(IB+I))                                          RPASS.129   
      C(JB+J)=2.0*(A(IA+I)-A(IB+I))                                          RPASS.130   
      I=I+INC3                                                               RPASS.131   
      J=J+INC4                                                               RPASS.132   
  292 CONTINUE                                                               RPASS.133   
      IBASE=IBASE+INC1                                                       RPASS.134   
      JBASE=JBASE+INC2                                                       RPASS.135   
  294 CONTINUE                                                               RPASS.136   
      GO TO 900                                                              RPASS.137   
C                                                                            RPASS.138   
C     CODING FOR FACTOR 3                                                    RPASS.139   
C     -------------------                                                    RPASS.140   
  300 CONTINUE                                                               RPASS.141   
      IA=1                                                                   RPASS.142   
      IB=IA+(2*M-LA)*INC1                                                    RPASS.143   
      IC=IB                                                                  RPASS.144   
      JA=1                                                                   RPASS.145   
      JB=JA+JINK                                                             RPASS.146   
      JC=JB+JINK                                                             RPASS.147   
C                                                                            RPASS.148   
      IF (LA.EQ.M) GO TO 390                                                 RPASS.149   
C                                                                            RPASS.150   
      DO 320 L=1,LA                                                          RPASS.151   
      I=IBASE                                                                RPASS.152   
      J=JBASE                                                                RPASS.153   
CDIR$ IVDEP                                                                  RPASS.154   
      DO 310 IJK=1,LOT                                                       RPASS.155   
      C(JA+J)=A(IA+I)+A(IB+I)                                                RPASS.156   
      C(JB+J)=(A(IA+I)-0.5*A(IB+I))-(SIN60*(B(IB+I)))                        RPASS.157   
      C(JC+J)=(A(IA+I)-0.5*A(IB+I))+(SIN60*(B(IB+I)))                        RPASS.158   
      I=I+INC3                                                               RPASS.159   
      J=J+INC4                                                               RPASS.160   
  310 CONTINUE                                                               RPASS.161   
      IBASE=IBASE+INC1                                                       RPASS.162   
      JBASE=JBASE+INC2                                                       RPASS.163   
  320 CONTINUE                                                               RPASS.164   
      IA=IA+IINK                                                             RPASS.165   
      IINK=2*IINK                                                            RPASS.166   
      IB=IB+IINK                                                             RPASS.167   
      IC=IC-IINK                                                             RPASS.168   
      JBASE=JBASE+JUMP                                                       RPASS.169   
      JUMP=2*JUMP+JINK                                                       RPASS.170   
      IF (IA.EQ.IC) GO TO 360                                                RPASS.171   
      DO 350 K=LA,KSTOP,LA                                                   RPASS.172   
      KB=K+K                                                                 RPASS.173   
      KC=KB+KB                                                               RPASS.174   
      C1=TRIGS(KB+1)                                                         RPASS.175   
      S1=TRIGS(KB+2)                                                         RPASS.176   
      C2=TRIGS(KC+1)                                                         RPASS.177   
      S2=TRIGS(KC+2)                                                         RPASS.178   
      IBASE=0                                                                RPASS.179   
      DO 340 L=1,LA                                                          RPASS.180   
      I=IBASE                                                                RPASS.181   
      J=JBASE                                                                RPASS.182   
CDIR$ IVDEP                                                                  RPASS.183   
      DO 330 IJK=1,LOT                                                       RPASS.184   
      C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I))                                      RPASS.185   
      D(JA+J)=B(IA+I)+(B(IB+I)-B(IC+I))                                      RPASS.186   
      C(JB+J)=                                                               RPASS.187   
     *    C1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)+B(IC+I))))     RPASS.188   
     *   -S1*((B(IA+I)-0.5*(B(IB+I)-B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))))     RPASS.189   
      D(JB+J)=                                                               RPASS.190   
     *    S1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)+B(IC+I))))     RPASS.191   
     *   +C1*((B(IA+I)-0.5*(B(IB+I)-B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))))     RPASS.192   
      C(JC+J)=                                                               RPASS.193   
     *    C2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)+B(IC+I))))     RPASS.194   
     *   -S2*((B(IA+I)-0.5*(B(IB+I)-B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))))     RPASS.195   
      D(JC+J)=                                                               RPASS.196   
     *    S2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)+B(IC+I))))     RPASS.197   
     *   +C2*((B(IA+I)-0.5*(B(IB+I)-B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))))     RPASS.198   
      I=I+INC3                                                               RPASS.199   
      J=J+INC4                                                               RPASS.200   
  330 CONTINUE                                                               RPASS.201   
      IBASE=IBASE+INC1                                                       RPASS.202   
      JBASE=JBASE+INC2                                                       RPASS.203   
  340 CONTINUE                                                               RPASS.204   
      IA=IA+IINK                                                             RPASS.205   
      IB=IB+IINK                                                             RPASS.206   
      IC=IC-IINK                                                             RPASS.207   
      JBASE=JBASE+JUMP                                                       RPASS.208   
  350 CONTINUE                                                               RPASS.209   
      IF (IA.GT.IC) GO TO 900                                                RPASS.210   
  360 CONTINUE                                                               RPASS.211   
      IBASE=0                                                                RPASS.212   
      DO 380 L=1,LA                                                          RPASS.213   
      I=IBASE                                                                RPASS.214   
      J=JBASE                                                                RPASS.215   
CDIR$ IVDEP                                                                  RPASS.216   
      DO 370 IJK=1,LOT                                                       RPASS.217   
      C(JA+J)=A(IA+I)+A(IB+I)                                                RPASS.218   
      C(JB+J)=(0.5*A(IA+I)-A(IB+I))-(SIN60*B(IA+I))                          RPASS.219   
      C(JC+J)=-(0.5*A(IA+I)-A(IB+I))-(SIN60*B(IA+I))                         RPASS.220   
      I=I+INC3                                                               RPASS.221   
      J=J+INC4                                                               RPASS.222   
  370 CONTINUE                                                               RPASS.223   
      IBASE=IBASE+INC1                                                       RPASS.224   
      JBASE=JBASE+INC2                                                       RPASS.225   
  380 CONTINUE                                                               RPASS.226   
      GO TO 900                                                              RPASS.227   
C                                                                            RPASS.228   
  390 CONTINUE                                                               RPASS.229   
      SSIN60=2.0*SIN60                                                       RPASS.230   
      DO 394 L=1,LA                                                          RPASS.231   
      I=IBASE                                                                RPASS.232   
      J=JBASE                                                                RPASS.233   
CDIR$ IVDEP                                                                  RPASS.234   
      DO 392 IJK=1,LOT                                                       RPASS.235   
      C(JA+J)=2.0*(A(IA+I)+A(IB+I))                                          RPASS.236   
      C(JB+J)=(2.0*A(IA+I)-A(IB+I))-(SSIN60*B(IB+I))                         RPASS.237   
      C(JC+J)=(2.0*A(IA+I)-A(IB+I))+(SSIN60*B(IB+I))                         RPASS.238   
      I=I+INC3                                                               RPASS.239   
      J=J+INC4                                                               RPASS.240   
  392 CONTINUE                                                               RPASS.241   
      IBASE=IBASE+INC1                                                       RPASS.242   
      JBASE=JBASE+INC2                                                       RPASS.243   
  394 CONTINUE                                                               RPASS.244   
      GO TO 900                                                              RPASS.245   
C                                                                            RPASS.246   
C     CODING FOR FACTOR 4                                                    RPASS.247   
C     -------------------                                                    RPASS.248   
  400 CONTINUE                                                               RPASS.249   
      IA=1                                                                   RPASS.250   
      IB=IA+(2*M-LA)*INC1                                                    RPASS.251   
      IC=IB+2*M*INC1                                                         RPASS.252   
      ID=IB                                                                  RPASS.253   
      JA=1                                                                   RPASS.254   
      JB=JA+JINK                                                             RPASS.255   
      JC=JB+JINK                                                             RPASS.256   
      JD=JC+JINK                                                             RPASS.257   
C                                                                            RPASS.258   
      IF (LA.EQ.M) GO TO 490                                                 RPASS.259   
C                                                                            RPASS.260   
      DO 420 L=1,LA                                                          RPASS.261   
      I=IBASE                                                                RPASS.262   
      J=JBASE                                                                RPASS.263   
CDIR$ IVDEP                                                                  RPASS.264   
      DO 410 IJK=1,LOT                                                       RPASS.265   
      C(JA+J)=(A(IA+I)+A(IC+I))+A(IB+I)                                      RPASS.266   
      C(JB+J)=(A(IA+I)-A(IC+I))-B(IB+I)                                      RPASS.267   
      C(JC+J)=(A(IA+I)+A(IC+I))-A(IB+I)                                      RPASS.268   
      C(JD+J)=(A(IA+I)-A(IC+I))+B(IB+I)                                      RPASS.269   
      I=I+INC3                                                               RPASS.270   
      J=J+INC4                                                               RPASS.271   
  410 CONTINUE                                                               RPASS.272   
      IBASE=IBASE+INC1                                                       RPASS.273   
      JBASE=JBASE+INC2                                                       RPASS.274   
  420 CONTINUE                                                               RPASS.275   
      IA=IA+IINK                                                             RPASS.276   
      IINK=2*IINK                                                            RPASS.277   
      IB=IB+IINK                                                             RPASS.278   
      IC=IC-IINK                                                             RPASS.279   
      ID=ID-IINK                                                             RPASS.280   
      JBASE=JBASE+JUMP                                                       RPASS.281   
      JUMP=2*JUMP+JINK                                                       RPASS.282   
      IF (IB.EQ.IC) GO TO 460                                                RPASS.283   
      DO 450 K=LA,KSTOP,LA                                                   RPASS.284   
      KB=K+K                                                                 RPASS.285   
      KC=KB+KB                                                               RPASS.286   
      KD=KC+KB                                                               RPASS.287   
      C1=TRIGS(KB+1)                                                         RPASS.288   
      S1=TRIGS(KB+2)                                                         RPASS.289   
      C2=TRIGS(KC+1)                                                         RPASS.290   
      S2=TRIGS(KC+2)                                                         RPASS.291   
      C3=TRIGS(KD+1)                                                         RPASS.292   
      S3=TRIGS(KD+2)                                                         RPASS.293   
      IBASE=0                                                                RPASS.294   
      DO 440 L=1,LA                                                          RPASS.295   
      I=IBASE                                                                RPASS.296   
      J=JBASE                                                                RPASS.297   
CDIR$ IVDEP                                                                  RPASS.298   
      DO 430 IJK=1,LOT                                                       RPASS.299   
      C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I))                            RPASS.300   
      D(JA+J)=(B(IA+I)-B(IC+I))+(B(IB+I)-B(ID+I))                            RPASS.301   
      C(JC+J)=                                                               RPASS.302   
     *    C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)))                           RPASS.303   
     *   -S2*((B(IA+I)-B(IC+I))-(B(IB+I)-B(ID+I)))                           RPASS.304   
      D(JC+J)=                                                               RPASS.305   
     *    S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)))                           RPASS.306   
     *   +C2*((B(IA+I)-B(IC+I))-(B(IB+I)-B(ID+I)))                           RPASS.307   
      C(JB+J)=                                                               RPASS.308   
     *    C1*((A(IA+I)-A(IC+I))-(B(IB+I)+B(ID+I)))                           RPASS.309   
     *   -S1*((B(IA+I)+B(IC+I))+(A(IB+I)-A(ID+I)))                           RPASS.310   
      D(JB+J)=                                                               RPASS.311   
     *    S1*((A(IA+I)-A(IC+I))-(B(IB+I)+B(ID+I)))                           RPASS.312   
     *   +C1*((B(IA+I)+B(IC+I))+(A(IB+I)-A(ID+I)))                           RPASS.313   
      C(JD+J)=                                                               RPASS.314   
     *    C3*((A(IA+I)-A(IC+I))+(B(IB+I)+B(ID+I)))                           RPASS.315   
     *   -S3*((B(IA+I)+B(IC+I))-(A(IB+I)-A(ID+I)))                           RPASS.316   
      D(JD+J)=                                                               RPASS.317   
     *    S3*((A(IA+I)-A(IC+I))+(B(IB+I)+B(ID+I)))                           RPASS.318   
     *   +C3*((B(IA+I)+B(IC+I))-(A(IB+I)-A(ID+I)))                           RPASS.319   
      I=I+INC3                                                               RPASS.320   
      J=J+INC4                                                               RPASS.321   
  430 CONTINUE                                                               RPASS.322   
      IBASE=IBASE+INC1                                                       RPASS.323   
      JBASE=JBASE+INC2                                                       RPASS.324   
  440 CONTINUE                                                               RPASS.325   
      IA=IA+IINK                                                             RPASS.326   
      IB=IB+IINK                                                             RPASS.327   
      IC=IC-IINK                                                             RPASS.328   
      ID=ID-IINK                                                             RPASS.329   
      JBASE=JBASE+JUMP                                                       RPASS.330   
  450 CONTINUE                                                               RPASS.331   
      IF (IB.GT.IC) GO TO 900                                                RPASS.332   
  460 CONTINUE                                                               RPASS.333   
      IBASE=0                                                                RPASS.334   
      SIN45=SQRT(0.5)                                                        RPASS.335   
      DO 480 L=1,LA                                                          RPASS.336   
      I=IBASE                                                                RPASS.337   
      J=JBASE                                                                RPASS.338   
CDIR$ IVDEP                                                                  RPASS.339   
      DO 470 IJK=1,LOT                                                       RPASS.340   
      C(JA+J)=A(IA+I)+A(IB+I)                                                RPASS.341   
      C(JB+J)=SIN45*((A(IA+I)-A(IB+I))-(B(IA+I)+B(IB+I)))                    RPASS.342   
      C(JC+J)=B(IB+I)-B(IA+I)                                                RPASS.343   
      C(JD+J)=-SIN45*((A(IA+I)-A(IB+I))+(B(IA+I)+B(IB+I)))                   RPASS.344   
      I=I+INC3                                                               RPASS.345   
      J=J+INC4                                                               RPASS.346   
  470 CONTINUE                                                               RPASS.347   
      IBASE=IBASE+INC1                                                       RPASS.348   
      JBASE=JBASE+INC2                                                       RPASS.349   
  480 CONTINUE                                                               RPASS.350   
      GO TO 900                                                              RPASS.351   
C                                                                            RPASS.352   
  490 CONTINUE                                                               RPASS.353   
      DO 494 L=1,LA                                                          RPASS.354   
      I=IBASE                                                                RPASS.355   
      J=JBASE                                                                RPASS.356   
CDIR$ IVDEP                                                                  RPASS.357   
      DO 492 IJK=1,LOT                                                       RPASS.358   
      C(JA+J)=2.0*((A(IA+I)+A(IC+I))+A(IB+I))                                RPASS.359   
      C(JB+J)=2.0*((A(IA+I)-A(IC+I))-B(IB+I))                                RPASS.360   
      C(JC+J)=2.0*((A(IA+I)+A(IC+I))-A(IB+I))                                RPASS.361   
      C(JD+J)=2.0*((A(IA+I)-A(IC+I))+B(IB+I))                                RPASS.362   
      I=I+INC3                                                               RPASS.363   
      J=J+INC4                                                               RPASS.364   
  492 CONTINUE                                                               RPASS.365   
      IBASE=IBASE+INC1                                                       RPASS.366   
      JBASE=JBASE+INC2                                                       RPASS.367   
  494 CONTINUE                                                               RPASS.368   
      GO TO 900                                                              RPASS.369   
C                                                                            RPASS.370   
C     CODING FOR FACTOR 5                                                    RPASS.371   
C     -------------------                                                    RPASS.372   
  500 CONTINUE                                                               RPASS.373   
      IA=1                                                                   RPASS.374   
      IB=IA+(2*M-LA)*INC1                                                    RPASS.375   
      IC=IB+2*M*INC1                                                         RPASS.376   
      ID=IC                                                                  RPASS.377   
      IE=IB                                                                  RPASS.378   
      JA=1                                                                   RPASS.379   
      JB=JA+JINK                                                             RPASS.380   
      JC=JB+JINK                                                             RPASS.381   
      JD=JC+JINK                                                             RPASS.382   
      JE=JD+JINK                                                             RPASS.383   
C                                                                            RPASS.384   
      IF (LA.EQ.M) GO TO 590                                                 RPASS.385   
C                                                                            RPASS.386   
      DO 520 L=1,LA                                                          RPASS.387   
      I=IBASE                                                                RPASS.388   
      J=JBASE                                                                RPASS.389   
CDIR$ IVDEP                                                                  RPASS.390   
      DO 510 IJK=1,LOT                                                       RPASS.391   
      C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I))                                      RPASS.392   
      C(JB+J)=((A(IA+I)-0.25*(A(IB+I)+A(IC+I)))+QRT5*(A(IB+I)-A(IC+I)))      RPASS.393   
     *    -(SIN72*B(IB+I)+SIN36*B(IC+I))                                     RPASS.394   
      C(JC+J)=((A(IA+I)-0.25*(A(IB+I)+A(IC+I)))-QRT5*(A(IB+I)-A(IC+I)))      RPASS.395   
     *    -(SIN36*B(IB+I)-SIN72*B(IC+I))                                     RPASS.396   
      C(JD+J)=((A(IA+I)-0.25*(A(IB+I)+A(IC+I)))-QRT5*(A(IB+I)-A(IC+I)))      RPASS.397   
     *    +(SIN36*B(IB+I)-SIN72*B(IC+I))                                     RPASS.398   
      C(JE+J)=((A(IA+I)-0.25*(A(IB+I)+A(IC+I)))+QRT5*(A(IB+I)-A(IC+I)))      RPASS.399   
     *    +(SIN72*B(IB+I)+SIN36*B(IC+I))                                     RPASS.400   
      I=I+INC3                                                               RPASS.401   
      J=J+INC4                                                               RPASS.402   
  510 CONTINUE                                                               RPASS.403   
      IBASE=IBASE+INC1                                                       RPASS.404   
      JBASE=JBASE+INC2                                                       RPASS.405   
  520 CONTINUE                                                               RPASS.406   
      IA=IA+IINK                                                             RPASS.407   
      IINK=2*IINK                                                            RPASS.408   
      IB=IB+IINK                                                             RPASS.409   
      IC=IC+IINK                                                             RPASS.410   
      ID=ID-IINK                                                             RPASS.411   
      IE=IE-IINK                                                             RPASS.412   
      JBASE=JBASE+JUMP                                                       RPASS.413   
      JUMP=2*JUMP+JINK                                                       RPASS.414   
      IF (IB.EQ.ID) GO TO 560                                                RPASS.415   
      DO 550 K=LA,KSTOP,LA                                                   RPASS.416   
      KB=K+K                                                                 RPASS.417   
      KC=KB+KB                                                               RPASS.418   
      KD=KC+KB                                                               RPASS.419   
      KE=KD+KB                                                               RPASS.420   
      C1=TRIGS(KB+1)                                                         RPASS.421   
      S1=TRIGS(KB+2)                                                         RPASS.422   
      C2=TRIGS(KC+1)                                                         RPASS.423   
      S2=TRIGS(KC+2)                                                         RPASS.424   
      C3=TRIGS(KD+1)                                                         RPASS.425   
      S3=TRIGS(KD+2)                                                         RPASS.426   
      C4=TRIGS(KE+1)                                                         RPASS.427   
      S4=TRIGS(KE+2)                                                         RPASS.428   
      IBASE=0                                                                RPASS.429   
      DO 540 L=1,LA                                                          RPASS.430   
      I=IBASE                                                                RPASS.431   
      J=JBASE                                                                RPASS.432   
CDIR$ IVDEP                                                                  RPASS.433   
      DO 530 IJK=1,LOT                                                       RPASS.434   
C                                                                            RPASS.435   
      A10(IJK)=(A(IA+I)-0.25*((A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I))))          RPASS.436   
     *    +QRT5*((A(IB+I)+A(IE+I))-(A(IC+I)+A(ID+I)))                        RPASS.437   
      A20(IJK)=(A(IA+I)-0.25*((A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I))))          RPASS.438   
     *    -QRT5*((A(IB+I)+A(IE+I))-(A(IC+I)+A(ID+I)))                        RPASS.439   
      B10(IJK)=(B(IA+I)-0.25*((B(IB+I)-B(IE+I))+(B(IC+I)-B(ID+I))))          RPASS.440   
     *    +QRT5*((B(IB+I)-B(IE+I))-(B(IC+I)-B(ID+I)))                        RPASS.441   
      B20(IJK)=(B(IA+I)-0.25*((B(IB+I)-B(IE+I))+(B(IC+I)-B(ID+I))))          RPASS.442   
     *    -QRT5*((B(IB+I)-B(IE+I))-(B(IC+I)-B(ID+I)))                        RPASS.443   
      A11(IJK)=SIN72*(B(IB+I)+B(IE+I))+SIN36*(B(IC+I)+B(ID+I))               RPASS.444   
      A21(IJK)=SIN36*(B(IB+I)+B(IE+I))-SIN72*(B(IC+I)+B(ID+I))               RPASS.445   
      B11(IJK)=SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))               RPASS.446   
      B21(IJK)=SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))               RPASS.447   
C                                                                            RPASS.448   
      C(JA+J)=A(IA+I)+((A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)))                  RPASS.449   
      D(JA+J)=B(IA+I)+((B(IB+I)-B(IE+I))+(B(IC+I)-B(ID+I)))                  RPASS.450   
      C(JB+J)=C1*(A10(IJK)-A11(IJK))-S1*(B10(IJK)+B11(IJK))                  RPASS.451   
      D(JB+J)=S1*(A10(IJK)-A11(IJK))+C1*(B10(IJK)+B11(IJK))                  RPASS.452   
      C(JE+J)=C4*(A10(IJK)+A11(IJK))-S4*(B10(IJK)-B11(IJK))                  RPASS.453   
      D(JE+J)=S4*(A10(IJK)+A11(IJK))+C4*(B10(IJK)-B11(IJK))                  RPASS.454   
      C(JC+J)=C2*(A20(IJK)-A21(IJK))-S2*(B20(IJK)+B21(IJK))                  RPASS.455   
      D(JC+J)=S2*(A20(IJK)-A21(IJK))+C2*(B20(IJK)+B21(IJK))                  RPASS.456   
      C(JD+J)=C3*(A20(IJK)+A21(IJK))-S3*(B20(IJK)-B21(IJK))                  RPASS.457   
      D(JD+J)=S3*(A20(IJK)+A21(IJK))+C3*(B20(IJK)-B21(IJK))                  RPASS.458   
C                                                                            RPASS.459   
      I=I+INC3                                                               RPASS.460   
      J=J+INC4                                                               RPASS.461   
  530 CONTINUE                                                               RPASS.462   
      IBASE=IBASE+INC1                                                       RPASS.463   
      JBASE=JBASE+INC2                                                       RPASS.464   
  540 CONTINUE                                                               RPASS.465   
      IA=IA+IINK                                                             RPASS.466   
      IB=IB+IINK                                                             RPASS.467   
      IC=IC+IINK                                                             RPASS.468   
      ID=ID-IINK                                                             RPASS.469   
      IE=IE-IINK                                                             RPASS.470   
      JBASE=JBASE+JUMP                                                       RPASS.471   
  550 CONTINUE                                                               RPASS.472   
      IF (IB.GT.ID) GO TO 900                                                RPASS.473   
  560 CONTINUE                                                               RPASS.474   
      IBASE=0                                                                RPASS.475   
      DO 580 L=1,LA                                                          RPASS.476   
      I=IBASE                                                                RPASS.477   
      J=JBASE                                                                RPASS.478   
CDIR$ IVDEP                                                                  RPASS.479   
      DO 570 IJK=1,LOT                                                       RPASS.480   
      C(JA+J)=(A(IA+I)+A(IB+I))+A(IC+I)                                      RPASS.481   
      C(JB+J)=(QRT5*(A(IA+I)-A(IB+I))+(0.25*(A(IA+I)+A(IB+I))-A(IC+I)))      RPASS.482   
     *    -(SIN36*B(IA+I)+SIN72*B(IB+I))                                     RPASS.483   
      C(JE+J)=-(QRT5*(A(IA+I)-A(IB+I))+(0.25*(A(IA+I)+A(IB+I))-A(IC+I)))     RPASS.484   
     *    -(SIN36*B(IA+I)+SIN72*B(IB+I))                                     RPASS.485   
      C(JC+J)=(QRT5*(A(IA+I)-A(IB+I))-(0.25*(A(IA+I)+A(IB+I))-A(IC+I)))      RPASS.486   
     *    -(SIN72*B(IA+I)-SIN36*B(IB+I))                                     RPASS.487   
      C(JD+J)=-(QRT5*(A(IA+I)-A(IB+I))-(0.25*(A(IA+I)+A(IB+I))-A(IC+I)))     RPASS.488   
     *    -(SIN72*B(IA+I)-SIN36*B(IB+I))                                     RPASS.489   
      I=I+INC3                                                               RPASS.490   
      J=J+INC4                                                               RPASS.491   
  570 CONTINUE                                                               RPASS.492   
      IBASE=IBASE+INC1                                                       RPASS.493   
      JBASE=JBASE+INC2                                                       RPASS.494   
  580 CONTINUE                                                               RPASS.495   
      GO TO 900                                                              RPASS.496   
C                                                                            RPASS.497   
  590 CONTINUE                                                               RPASS.498   
      QQRT5=2.0*QRT5                                                         RPASS.499   
      SSIN36=2.0*SIN36                                                       RPASS.500   
      SSIN72=2.0*SIN72                                                       RPASS.501   
      DO 594 L=1,LA                                                          RPASS.502   
      I=IBASE                                                                RPASS.503   
      J=JBASE                                                                RPASS.504   
CDIR$ IVDEP                                                                  RPASS.505   
      DO 592 IJK=1,LOT                                                       RPASS.506   
      C(JA+J)=2.0*(A(IA+I)+(A(IB+I)+A(IC+I)))                                RPASS.507   
      C(JB+J)=(2.0*(A(IA+I)-0.25*(A(IB+I)+A(IC+I)))                          RPASS.508   
     *    +QQRT5*(A(IB+I)-A(IC+I)))-(SSIN72*B(IB+I)+SSIN36*B(IC+I))          RPASS.509   
      C(JC+J)=(2.0*(A(IA+I)-0.25*(A(IB+I)+A(IC+I)))                          RPASS.510   
     *    -QQRT5*(A(IB+I)-A(IC+I)))-(SSIN36*B(IB+I)-SSIN72*B(IC+I))          RPASS.511   
      C(JD+J)=(2.0*(A(IA+I)-0.25*(A(IB+I)+A(IC+I)))                          RPASS.512   
     *    -QQRT5*(A(IB+I)-A(IC+I)))+(SSIN36*B(IB+I)-SSIN72*B(IC+I))          RPASS.513   
      C(JE+J)=(2.0*(A(IA+I)-0.25*(A(IB+I)+A(IC+I)))                          RPASS.514   
     *    +QQRT5*(A(IB+I)-A(IC+I)))+(SSIN72*B(IB+I)+SSIN36*B(IC+I))          RPASS.515   
      I=I+INC3                                                               RPASS.516   
      J=J+INC4                                                               RPASS.517   
  592 CONTINUE                                                               RPASS.518   
      IBASE=IBASE+INC1                                                       RPASS.519   
      JBASE=JBASE+INC2                                                       RPASS.520   
  594 CONTINUE                                                               RPASS.521   
      GO TO 900                                                              RPASS.522   
C                                                                            RPASS.523   
C     CODING FOR FACTOR 6                                                    RPASS.524   
C     -------------------                                                    RPASS.525   
  600 CONTINUE                                                               RPASS.526   
      IA=1                                                                   RPASS.527   
      IB=IA+(2*M-LA)*INC1                                                    RPASS.528   
      IC=IB+2*M*INC1                                                         RPASS.529   
      ID=IC+2*M*INC1                                                         RPASS.530   
      IE=IC                                                                  RPASS.531   
      IF=IB                                                                  RPASS.532   
      JA=1                                                                   RPASS.533   
      JB=JA+JINK                                                             RPASS.534   
      JC=JB+JINK                                                             RPASS.535   
      JD=JC+JINK                                                             RPASS.536   
      JE=JD+JINK                                                             RPASS.537   
      JF=JE+JINK                                                             RPASS.538   
C                                                                            RPASS.539   
      IF (LA.EQ.M) GO TO 690                                                 RPASS.540   
C                                                                            RPASS.541   
      DO 620 L=1,LA                                                          RPASS.542   
      I=IBASE                                                                RPASS.543   
      J=JBASE                                                                RPASS.544   
CDIR$ IVDEP                                                                  RPASS.545   
      DO 610 IJK=1,LOT                                                       RPASS.546   
      C(JA+J)=(A(IA+I)+A(ID+I))+(A(IB+I)+A(IC+I))                            RPASS.547   
      C(JD+J)=(A(IA+I)-A(ID+I))-(A(IB+I)-A(IC+I))                            RPASS.548   
      C(JB+J)=((A(IA+I)-A(ID+I))+0.5*(A(IB+I)-A(IC+I)))                      RPASS.549   
     *    -(SIN60*(B(IB+I)+B(IC+I)))                                         RPASS.550   
      C(JF+J)=((A(IA+I)-A(ID+I))+0.5*(A(IB+I)-A(IC+I)))                      RPASS.551   
     *    +(SIN60*(B(IB+I)+B(IC+I)))                                         RPASS.552   
      C(JC+J)=((A(IA+I)+A(ID+I))-0.5*(A(IB+I)+A(IC+I)))                      RPASS.553   
     *    -(SIN60*(B(IB+I)-B(IC+I)))                                         RPASS.554   
      C(JE+J)=((A(IA+I)+A(ID+I))-0.5*(A(IB+I)+A(IC+I)))                      RPASS.555   
     *    +(SIN60*(B(IB+I)-B(IC+I)))                                         RPASS.556   
      I=I+INC3                                                               RPASS.557   
      J=J+INC4                                                               RPASS.558   
  610 CONTINUE                                                               RPASS.559   
      IBASE=IBASE+INC1                                                       RPASS.560   
      JBASE=JBASE+INC2                                                       RPASS.561   
  620 CONTINUE                                                               RPASS.562   
      IA=IA+IINK                                                             RPASS.563   
      IINK=2*IINK                                                            RPASS.564   
      IB=IB+IINK                                                             RPASS.565   
      IC=IC+IINK                                                             RPASS.566   
      ID=ID-IINK                                                             RPASS.567   
      IE=IE-IINK                                                             RPASS.568   
      IF=IF-IINK                                                             RPASS.569   
      JBASE=JBASE+JUMP                                                       RPASS.570   
      JUMP=2*JUMP+JINK                                                       RPASS.571   
      IF (IC.EQ.ID) GO TO 660                                                RPASS.572   
      DO 650 K=LA,KSTOP,LA                                                   RPASS.573   
      KB=K+K                                                                 RPASS.574   
      KC=KB+KB                                                               RPASS.575   
      KD=KC+KB                                                               RPASS.576   
      KE=KD+KB                                                               RPASS.577   
      KF=KE+KB                                                               RPASS.578   
      C1=TRIGS(KB+1)                                                         RPASS.579   
      S1=TRIGS(KB+2)                                                         RPASS.580   
      C2=TRIGS(KC+1)                                                         RPASS.581   
      S2=TRIGS(KC+2)                                                         RPASS.582   
      C3=TRIGS(KD+1)                                                         RPASS.583   
      S3=TRIGS(KD+2)                                                         RPASS.584   
      C4=TRIGS(KE+1)                                                         RPASS.585   
      S4=TRIGS(KE+2)                                                         RPASS.586   
      C5=TRIGS(KF+1)                                                         RPASS.587   
      S5=TRIGS(KF+2)                                                         RPASS.588   
      IBASE=0                                                                RPASS.589   
      DO 640 L=1,LA                                                          RPASS.590   
      I=IBASE                                                                RPASS.591   
      J=JBASE                                                                RPASS.592   
CDIR$ IVDEP                                                                  RPASS.593   
      DO 630 IJK=1,LOT                                                       RPASS.594   
C                                                                            RPASS.595   
      A11(IJK)= (A(IE+I)+A(IB+I))+(A(IC+I)+A(IF+I))                          RPASS.596   
      A20(IJK)=(A(IA+I)+A(ID+I))-0.5*A11(IJK)                                RPASS.597   
      A21(IJK)=SIN60*((A(IE+I)+A(IB+I))-(A(IC+I)+A(IF+I)))                   RPASS.598   
      B11(IJK)= (B(IB+I)-B(IE+I))+(B(IC+I)-B(IF+I))                          RPASS.599   
      B20(IJK)=(B(IA+I)-B(ID+I))-0.5*B11(IJK)                                RPASS.600   
      B21(IJK)=SIN60*((B(IB+I)-B(IE+I))-(B(IC+I)-B(IF+I)))                   RPASS.601   
C                                                                            RPASS.602   
      C(JA+J)=(A(IA+I)+A(ID+I))+A11(IJK)                                     RPASS.603   
      D(JA+J)=(B(IA+I)-B(ID+I))+B11(IJK)                                     RPASS.604   
      C(JC+J)=C2*(A20(IJK)-B21(IJK))-S2*(B20(IJK)+A21(IJK))                  RPASS.605   
      D(JC+J)=S2*(A20(IJK)-B21(IJK))+C2*(B20(IJK)+A21(IJK))                  RPASS.606   
      C(JE+J)=C4*(A20(IJK)+B21(IJK))-S4*(B20(IJK)-A21(IJK))                  RPASS.607   
      D(JE+J)=S4*(A20(IJK)+B21(IJK))+C4*(B20(IJK)-A21(IJK))                  RPASS.608   
C                                                                            RPASS.609   
      A11(IJK)=(A(IE+I)-A(IB+I))+(A(IC+I)-A(IF+I))                           RPASS.610   
      B11(IJK)=(B(IE+I)+B(IB+I))-(B(IC+I)+B(IF+I))                           RPASS.611   
      A20(IJK)=(A(IA+I)-A(ID+I))-0.5*A11(IJK)                                RPASS.612   
      A21(IJK)=SIN60*((A(IE+I)-A(IB+I))-(A(IC+I)-A(IF+I)))                   RPASS.613   
      B20(IJK)=(B(IA+I)+B(ID+I))+0.5*B11(IJK)                                RPASS.614   
      B21(IJK)=SIN60*((B(IE+I)+B(IB+I))+(B(IC+I)+B(IF+I)))                   RPASS.615   
C                                                                            RPASS.616   
      C(JD+J)=                                                               RPASS.617   
     *  C3*((A(IA+I)-A(ID+I))+A11(IJK))-S3*((B(IA+I)+B(ID+I))-B11(IJK))      RPASS.618   
      D(JD+J)=                                                               RPASS.619   
     *  S3*((A(IA+I)-A(ID+I))+A11(IJK))+C3*((B(IA+I)+B(ID+I))-B11(IJK))      RPASS.620   
      C(JB+J)=C1*(A20(IJK)-B21(IJK))-S1*(B20(IJK)-A21(IJK))                  RPASS.621   
      D(JB+J)=S1*(A20(IJK)-B21(IJK))+C1*(B20(IJK)-A21(IJK))                  RPASS.622   
      C(JF+J)=C5*(A20(IJK)+B21(IJK))-S5*(B20(IJK)+A21(IJK))                  RPASS.623   
      D(JF+J)=S5*(A20(IJK)+B21(IJK))+C5*(B20(IJK)+A21(IJK))                  RPASS.624   
C                                                                            RPASS.625   
      I=I+INC3                                                               RPASS.626   
      J=J+INC4                                                               RPASS.627   
  630 CONTINUE                                                               RPASS.628   
      IBASE=IBASE+INC1                                                       RPASS.629   
      JBASE=JBASE+INC2                                                       RPASS.630   
  640 CONTINUE                                                               RPASS.631   
      IA=IA+IINK                                                             RPASS.632   
      IB=IB+IINK                                                             RPASS.633   
      IC=IC+IINK                                                             RPASS.634   
      ID=ID-IINK                                                             RPASS.635   
      IE=IE-IINK                                                             RPASS.636   
      IF=IF-IINK                                                             RPASS.637   
      JBASE=JBASE+JUMP                                                       RPASS.638   
  650 CONTINUE                                                               RPASS.639   
      IF (IC.GT.ID) GO TO 900                                                RPASS.640   
  660 CONTINUE                                                               RPASS.641   
      IBASE=0                                                                RPASS.642   
      DO 680 L=1,LA                                                          RPASS.643   
      I=IBASE                                                                RPASS.644   
      J=JBASE                                                                RPASS.645   
CDIR$ IVDEP                                                                  RPASS.646   
      DO 670 IJK=1,LOT                                                       RPASS.647   
      C(JA+J)=A(IB+I)+(A(IA+I)+A(IC+I))                                      RPASS.648   
      C(JD+J)=B(IB+I)-(B(IA+I)+B(IC+I))                                      RPASS.649   
      C(JB+J)=(SIN60*(A(IA+I)-A(IC+I)))-(0.5*(B(IA+I)+B(IC+I))+B(IB+I))      RPASS.650   
      C(JF+J)=-(SIN60*(A(IA+I)-A(IC+I)))-(0.5*(B(IA+I)+B(IC+I))+B(IB+I))     RPASS.651   
      C(JC+J)=SIN60*(B(IC+I)-B(IA+I))+(0.5*(A(IA+I)+A(IC+I))-A(IB+I))        RPASS.652   
      C(JE+J)=SIN60*(B(IC+I)-B(IA+I))-(0.5*(A(IA+I)+A(IC+I))-A(IB+I))        RPASS.653   
      I=I+INC3                                                               RPASS.654   
      J=J+INC4                                                               RPASS.655   
  670 CONTINUE                                                               RPASS.656   
      IBASE=IBASE+INC1                                                       RPASS.657   
      JBASE=JBASE+INC2                                                       RPASS.658   
  680 CONTINUE                                                               RPASS.659   
      GO TO 900                                                              RPASS.660   
C                                                                            RPASS.661   
  690 CONTINUE                                                               RPASS.662   
      SSIN60=2.0*SIN60                                                       RPASS.663   
      DO 694 L=1,LA                                                          RPASS.664   
      I=IBASE                                                                RPASS.665   
      J=JBASE                                                                RPASS.666   
CDIR$ IVDEP                                                                  RPASS.667   
      DO 692 IJK=1,LOT                                                       RPASS.668   
      C(JA+J)=(2.0*(A(IA+I)+A(ID+I)))+(2.0*(A(IB+I)+A(IC+I)))                RPASS.669   
      C(JD+J)=(2.0*(A(IA+I)-A(ID+I)))-(2.0*(A(IB+I)-A(IC+I)))                RPASS.670   
      C(JB+J)=(2.0*(A(IA+I)-A(ID+I))+(A(IB+I)-A(IC+I)))                      RPASS.671   
     *    -(SSIN60*(B(IB+I)+B(IC+I)))                                        RPASS.672   
      C(JF+J)=(2.0*(A(IA+I)-A(ID+I))+(A(IB+I)-A(IC+I)))                      RPASS.673   
     *    +(SSIN60*(B(IB+I)+B(IC+I)))                                        RPASS.674   
      C(JC+J)=(2.0*(A(IA+I)+A(ID+I))-(A(IB+I)+A(IC+I)))                      RPASS.675   
     *    -(SSIN60*(B(IB+I)-B(IC+I)))                                        RPASS.676   
      C(JE+J)=(2.0*(A(IA+I)+A(ID+I))-(A(IB+I)+A(IC+I)))                      RPASS.677   
     *    +(SSIN60*(B(IB+I)-B(IC+I)))                                        RPASS.678   
      I=I+INC3                                                               RPASS.679   
      J=J+INC4                                                               RPASS.680   
  692 CONTINUE                                                               RPASS.681   
      IBASE=IBASE+INC1                                                       RPASS.682   
      JBASE=JBASE+INC2                                                       RPASS.683   
  694 CONTINUE                                                               RPASS.684   
      GO TO 900                                                              RPASS.685   
C                                                                            RPASS.686   
C     CODING FOR FACTOR 8                                                    RPASS.687   
C     -------------------                                                    RPASS.688   
  800 CONTINUE                                                               RPASS.689   
      IBAD=3                                                                 RPASS.690   
      IF (LA.NE.M) GO TO 910                                                 RPASS.691   
      IA=1                                                                   RPASS.692   
      IB=IA+LA*INC1                                                          RPASS.693   
      IC=IB+2*LA*INC1                                                        RPASS.694   
      ID=IC+2*LA*INC1                                                        RPASS.695   
      IE=ID+2*LA*INC1                                                        RPASS.696   
      JA=1                                                                   RPASS.697   
      JB=JA+JINK                                                             RPASS.698   
      JC=JB+JINK                                                             RPASS.699   
      JD=JC+JINK                                                             RPASS.700   
      JE=JD+JINK                                                             RPASS.701   
      JF=JE+JINK                                                             RPASS.702   
      JG=JF+JINK                                                             RPASS.703   
      JH=JG+JINK                                                             RPASS.704   
      SSIN45=SQRT(2.0)                                                       RPASS.705   
C                                                                            RPASS.706   
      DO 820 L=1,LA                                                          RPASS.707   
      I=IBASE                                                                RPASS.708   
      J=JBASE                                                                RPASS.709   
CDIR$ IVDEP                                                                  RPASS.710   
      DO 810 IJK=1,LOT                                                       RPASS.711   
      C(JA+J)=2.0*(((A(IA+I)+A(IE+I))+A(IC+I))+(A(IB+I)+A(ID+I)))            RPASS.712   
      C(JE+J)=2.0*(((A(IA+I)+A(IE+I))+A(IC+I))-(A(IB+I)+A(ID+I)))            RPASS.713   
      C(JC+J)=2.0*(((A(IA+I)+A(IE+I))-A(IC+I))-(B(IB+I)-B(ID+I)))            RPASS.714   
      C(JG+J)=2.0*(((A(IA+I)+A(IE+I))-A(IC+I))+(B(IB+I)-B(ID+I)))            RPASS.715   
      C(JB+J)=2.0*((A(IA+I)-A(IE+I))-B(IC+I))                                RPASS.716   
     *    +SSIN45*((A(IB+I)-A(ID+I))-(B(IB+I)+B(ID+I)))                      RPASS.717   
      C(JF+J)=2.0*((A(IA+I)-A(IE+I))-B(IC+I))                                RPASS.718   
     *    -SSIN45*((A(IB+I)-A(ID+I))-(B(IB+I)+B(ID+I)))                      RPASS.719   
      C(JD+J)=2.0*((A(IA+I)-A(IE+I))+B(IC+I))                                RPASS.720   
     *    -SSIN45*((A(IB+I)-A(ID+I))+(B(IB+I)+B(ID+I)))                      RPASS.721   
      C(JH+J)=2.0*((A(IA+I)-A(IE+I))+B(IC+I))                                RPASS.722   
     *    +SSIN45*((A(IB+I)-A(ID+I))+(B(IB+I)+B(ID+I)))                      RPASS.723   
      I=I+INC3                                                               RPASS.724   
      J=J+INC4                                                               RPASS.725   
  810 CONTINUE                                                               RPASS.726   
      IBASE=IBASE+INC1                                                       RPASS.727   
      JBASE=JBASE+INC2                                                       RPASS.728   
  820 CONTINUE                                                               RPASS.729   
C                                                                            RPASS.730   
C     RETURN                                                                 RPASS.731   
C     ------                                                                 RPASS.732   
  900 CONTINUE                                                               RPASS.733   
      IBAD=0                                                                 RPASS.734   
  910 CONTINUE                                                               RPASS.735   
      IERR=IBAD                                                              RPASS.736   
      RETURN                                                                 RPASS.737   
      END                                                                    RPASS.738   
C     ***************************************************************        RPASS.739   
      SUBROUTINE QPASSM(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC,        RPASS.740   
     *    LA,IERR)                                                           RPASS.741   
      DIMENSION A(N),B(N),C(N),D(N),TRIGS(N)                                 RPASS.742   
C                                                                            RPASS.743   
      RETURN                                                                 RPASS.744   
      END                                                                    RPASS.745   
C     ***************************************************************        RPASS.746   
C                                                                            DUMMY.2     
C     Dummy subroutines for ECMWF only program library.                      DUMMY.3     
C                                                                            DUMMY.4     
      SUBROUTINE INIARB                                                      DUMMY.5     
C                                                                            DUMMY.6     
      RETURN                                                                 DUMMY.7     
      END                                                                    DUMMY.8     
C     *********************************************************              DUMMY.9     
      SUBROUTINE READARB                                                     DUMMY.10    
C                                                                            DUMMY.11    
      RETURN                                                                 DUMMY.12    
      END                                                                    DUMMY.13    
C     *********************************************************              DUMMY.14    
      SUBROUTINE INIRS                                                       DUMMY.15    
C                                                                            DUMMY.16    
      RETURN                                                                 DUMMY.17    
      END                                                                    DUMMY.18    
C     *********************************************************              DUMMY.19    
      SUBROUTINE LEGDERV                                                     DUMMY.20    
C                                                                            DUMMY.21    
      RETURN                                                                 DUMMY.22    
      END                                                                    DUMMY.23    
C     *********************************************************              DUMMY.24    
      SUBROUTINE RSCOEFFS                                                    DUMMY.25    
C                                                                            DUMMY.26    
      RETURN                                                                 DUMMY.27    
      END                                                                    DUMMY.28    
C     *********************************************************              DUMMY.29    
      SUBROUTINE RSP2GRID                                                    DUMMY.30    
C                                                                            DUMMY.31    
      RETURN                                                                 DUMMY.32    
      END                                                                    DUMMY.33    
C     *********************************************************              DUMMY.34    
      SUBROUTINE INIUM                                                       DUMMY.35    
C                                                                            DUMMY.36    
      RETURN                                                                 DUMMY.37    
      END                                                                    DUMMY.38    
C     *********************************************************              DUMMY.39    
      SUBROUTINE READUM                                                      DUMMY.40    
C                                                                            DUMMY.41    
      RETURN                                                                 DUMMY.42    
      END                                                                    DUMMY.43    
C     *********************************************************              DUMMY.44    
      SUBROUTINE MAKEUM(FSTEM,IOFFSET,INPFNAME,NCDATE)                       DUMMY.45    
C                                                                            DUMMY.46    
      CHARACTER*80 FSTEM,INPFNAME                                            DUMMY.47    
      RETURN                                                                 DUMMY.48    
      END                                                                    DUMMY.49    
C     *********************************************************              DUMMY.50    
      SUBROUTINE CDXDAT(KCD,KD,KM,KY)                                        CDXDAT.2     
C                                                                            CDXDAT.3     
C             THIS SUBROUTINE CONVERTS                                       CDXDAT.4     
C             KCD       CENTURY DATE                                         CDXDAT.5     
C             BACK TO                                                        CDXDAT.6     
C             KD        DAY                                                  CDXDAT.7     
C             KM        MONTH                                                CDXDAT.8     
C             KY        YEAR (IN THE FORM 19XX, 20XX)                        CDXDAT.9     
C                                                                            CDXDAT.10    
C----------------------------------------------------------------------      CDXDAT.11    
C                                                                            CDXDAT.12    
      DIMENSION IDAYS(12),JDAYS(12)                                          CDXDAT.13    
      DATA IDAYS/0,31,59,90,120,151,181,212,243,273,304,334/                 CDXDAT.14    
      DATA JDAYS/0,31,60,91,121,152,182,213,244,274,305,335/                 CDXDAT.15    
C             FIND APPROXIMATE YEAR                                          CDXDAT.16    
C  NEW CODE                                                                  CDXDAT.17    
      IIKCD=KCD                                                              CDXDAT.18    
      IKCD=KCD                                                               CDXDAT.19    
      IF(KCD.GT.36524) THEN                                                  CDXDAT.20    
         IKCD=KCD-36525                                                      CDXDAT.21    
      ENDIF                                                                  CDXDAT.22    
      KY=IKCD/365                                                            CDXDAT.23    
      NDAYS=MOD(IKCD,365)                                                    CDXDAT.24    
C             SUBTRACT 1 DAY FOR EACH LEAP YEAR                              CDXDAT.25    
      ILY=(KY-1)/4                                                           CDXDAT.26    
      if(ky.eq.0) ily=-1                                                     CDXDAT.27    
      NDAYS=NDAYS-ILY                                                        CDXDAT.28    
      IF (NDAYS.GT.0) GO TO 10                                               CDXDAT.29    
C             ADD A YEAR IF NECCESSARY TO COMPENSATE FOR L.Y. DAYS           CDXDAT.30    
      NDAYS=NDAYS+365                                                        CDXDAT.31    
      KY=KY-1                                                                CDXDAT.32    
      IF (MOD(KY,4).EQ.0) NDAYS=NDAYS+1                                      CDXDAT.33    
   10 CONTINUE                                                               CDXDAT.34    
C             CORRECT YEAR FOR CENTURY                                       CDXDAT.35    
      KY=KY+1900                                                             CDXDAT.36    
      IF(KCD.GT.36524) KY=KY+100                                             CDXDAT.37    
C             TEST FOR CURRENT YEAR LEAP YEAR                                CDXDAT.38    
      IF (MOD(KY,4).EQ.0) GO TO 30                                           CDXDAT.39    
C             NON LEAP YEAR                                                  CDXDAT.40    
      DO 20 J=1,11                                                           CDXDAT.41    
      IF (IDAYS(J+1).GE.NDAYS) GO TO 25                                      CDXDAT.42    
   20 CONTINUE                                                               CDXDAT.43    
      J=12                                                                   CDXDAT.44    
   25 CONTINUE                                                               CDXDAT.45    
      KM=J                                                                   CDXDAT.46    
      KD=NDAYS-IDAYS(J)                                                      CDXDAT.47    
      RETURN                                                                 CDXDAT.48    
C----------------------------------------------------------------------      CDXDAT.49    
C             LEAP YEAR                                                      CDXDAT.50    
   30 CONTINUE                                                               CDXDAT.51    
      DO 40 J=1,11                                                           CDXDAT.52    
                                                                             CDXDAT.53    
      IF (JDAYS(J+1).GE.NDAYS) GO TO 45                                      CDXDAT.54    
   40 CONTINUE                                                               CDXDAT.55    
      J=12                                                                   CDXDAT.56    
   45 CONTINUE                                                               CDXDAT.57    
      KM=J                                                                   CDXDAT.58    
      KD=NDAYS-JDAYS(J)                                                      CDXDAT.59    
C                                                                            CDXDAT.60    
      RETURN                                                                 CDXDAT.61    
      END                                                                    CDXDAT.62    
C     ***************************************************************        CDXDAT.63    
      FUNCTION IDATXC(KD,KM,KY)                                              IDATXC.2     
C                                                                            IDATXC.3     
C             THIS FUNCTION RETURNS CENTURY DAY GIVEN                        IDATXC.4     
C             KD        DAY                                                  IDATXC.5     
C             KM        MONTH                                                IDATXC.6     
C             KY        YEAR (19XX, 20XX OR XX)                              IDATXC.7     
C                                                                            IDATXC.8     
C----------------------------------------------------------------------      IDATXC.9     
C                                                                            IDATXC.10    
      DIMENSION IDAYS(12),JDAYS(12)                                          IDATXC.11    
      DATA IDAYS/0,31,59,90,120,151,181,212,243,273,304,334/                 IDATXC.12    
      DATA JDAYS/0,31,60,91,121,152,182,213,244,274,305,335/                 IDATXC.13    
      IY=MOD(KY,100)                                                         IDATXC.14    
      IYDAY=IDAYS(KM)+KD                                                     IDATXC.15    
      IF (MOD(IY,4).EQ.0) IYDAY=JDAYS(KM)+KD                                 IDATXC.16    
      ILY=(IY-1)/4                                                           IDATXC.17    
      IF(KY.EQ.1900.OR.KY.EQ.00.OR.KY.EQ.2000) ILY=-1                        IDATXC.18    
      IDATXC=IY*365+ILY+IYDAY                                                IDATXC.19    
      IF(KY.GE.2000) IDATXC=IDATXC+36525                                     IDATXC.20    
C                                                                            IDATXC.21    
      RETURN                                                                 IDATXC.22    
      END                                                                    IDATXC.23    
C     ***********************************************************            IDATXC.24    
      SUBROUTINE CDXDAT2000(KCD,KD,KM,KY)                                    CDXDAT2.2     
C                                                                            CDXDAT2.3     
C             THIS SUBROUTINE CONVERTS                                       CDXDAT2.4     
C             KCD       DAY SINCE 1/1/1900                                   CDXDAT2.5     
C             BACK TO                                                        CDXDAT2.6     
C             KD        DAY                                                  CDXDAT2.7     
C             KM        MONTH                                                CDXDAT2.8     
C             KY        YEAR (IN THE FORM YYYY)                              CDXDAT2.9     
C                                                                            CDXDAT2.10    
C     Assuming all years nn00 are leap years                                 CDXDAT2.11    
C     (true for 2000,2400,.. but not for 1900,2100,etc).                     CDXDAT2.12    
C----------------------------------------------------------------------      CDXDAT2.13    
C                                                                            CDXDAT2.14    
      INTEGER KCD,KD,KM,KY,IY                                                CDXDAT2.15    
      DIMENSION IDAYS(12),JDAYS(12)                                          CDXDAT2.16    
      DATA IDAYS/0,31,59,90,120,151,181,212,243,273,304,334/                 CDXDAT2.17    
      DATA JDAYS/0,31,60,91,121,152,182,213,244,274,305,335/                 CDXDAT2.18    
C             FIND CENTURY                                                   CDXDAT2.19    
      NDPCEN=36525                                                           CDXDAT2.20    
      ICEN=KCD/NDPCEN+19                                                     CDXDAT2.21    
      IKCD=MOD(KCD,NDPCEN)                                                   CDXDAT2.22    
C             ESTIMATE YEAR                                                  CDXDAT2.23    
      IY=IKCD/365                                                            CDXDAT2.24    
      NDAYS=MOD(IKCD,365)                                                    CDXDAT2.25    
C             SUBTRACT 1 DAY FOR EACH LEAP YEAR IN THE CENTURY               CDXDAT2.26    
      ILY=(IY-1)/4+1                                                         CDXDAT2.27    
      IF (IY.EQ.0) ILY=0                                                     CDXDAT2.28    
      NDAYS=NDAYS-ILY                                                        CDXDAT2.29    
      IF (NDAYS.LE.0) THEN                                                   CDXDAT2.30    
C             ADD A YEAR IF NECCESSARY TO COMPENSATE FOR L.Y. DAYS           CDXDAT2.31    
         NDAYS=NDAYS+365                                                     CDXDAT2.32    
         IY=IY-1                                                             CDXDAT2.33    
         IF (MOD(IY,4).EQ.0) NDAYS=NDAYS+1                                   CDXDAT2.34    
      ENDIF                                                                  CDXDAT2.35    
C             TEST FOR CURRENT YEAR LEAP YEAR                                CDXDAT2.36    
      IF (MOD(IY,4).EQ.0) THEN                                               CDXDAT2.37    
C             LEAP YEAR                                                      CDXDAT2.38    
         DO 40 J=1,11                                                        CDXDAT2.39    
            IF (JDAYS(J+1).GE.NDAYS) GO TO 45                                CDXDAT2.40    
 40      CONTINUE                                                            CDXDAT2.41    
         J=12                                                                CDXDAT2.42    
 45      CONTINUE                                                            CDXDAT2.43    
         KM=J                                                                CDXDAT2.44    
         KD=NDAYS-JDAYS(J)                                                   CDXDAT2.45    
      ELSE                                                                   CDXDAT2.46    
C             NON LEAP YEAR                                                  CDXDAT2.47    
         DO 20 J=1,11                                                        CDXDAT2.48    
            IF (IDAYS(J+1).GE.NDAYS) GO TO 25                                CDXDAT2.49    
 20      CONTINUE                                                            CDXDAT2.50    
         J=12                                                                CDXDAT2.51    
 25      CONTINUE                                                            CDXDAT2.52    
         KM=J                                                                CDXDAT2.53    
         KD=NDAYS-IDAYS(J)                                                   CDXDAT2.54    
      ENDIF                                                                  CDXDAT2.55    
      KY=ICEN*100+IY                                                         CDXDAT2.56    
C                                                                            CDXDAT2.57    
      RETURN                                                                 CDXDAT2.58    
      END                                                                    CDXDAT2.59    
C     ***************************************************************        CDXDAT2.60    
      FUNCTION IDATXC2000(KD,KM,KY)                                          IDATXC2.2     
C                                                                            IDATXC2.3     
C             THIS FUNCTION RETURNS DAY SINCE 1/1/1900 GIVEN                 IDATXC2.4     
C             KD        DAY                                                  IDATXC2.5     
C             KM        MONTH                                                IDATXC2.6     
C             KY        YEAR (YYYY)                                          IDATXC2.7     
C                                                                            IDATXC2.8     
C     Assuming all years nn00 are leap years                                 IDATXC2.9     
C     (true for 2000,2400,.. but not for 1900,2100,etc).                     IDATXC2.10    
C----------------------------------------------------------------------      IDATXC2.11    
C                                                                            IDATXC2.12    
      INTEGER KD,KM,KY,IY                                                    IDATXC2.13    
      DIMENSION IDAYS(12),JDAYS(12)                                          IDATXC2.14    
      DATA IDAYS/0,31,59,90,120,151,181,212,243,273,304,334/                 IDATXC2.15    
      DATA JDAYS/0,31,60,91,121,152,182,213,244,274,305,335/                 IDATXC2.16    
C                                                                            IDATXC2.17    
      IY=MOD(KY,100)                                                         IDATXC2.18    
      ICEN=KY/100                                                            IDATXC2.19    
      NDPCEN=36525                                                           IDATXC2.20    
      IYDAY=IDAYS(KM)+KD                                                     IDATXC2.21    
      IF (MOD(IY,4).EQ.0) IYDAY=JDAYS(KM)+KD                                 IDATXC2.22    
      ILY=(IY-1)/4+1                                                         IDATXC2.23    
      IF (IY.EQ.0) ILY=0                                                     IDATXC2.24    
      IDATXC2000=(ICEN-19)*NDPCEN+IY*365+ILY+IYDAY                           IDATXC2.25    
C                                                                            IDATXC2.26    
      RETURN                                                                 IDATXC2.27    
      END                                                                    IDATXC2.28    
C     ***********************************************************            IDATXC2.29    
C                                                                            DUMGRIBEX.2     
C     Dummy subroutines for any call to GRIBEX.                              DUMGRIBEX.3     
C                                                                            DUMGRIBEX.4     
C     **********************************************************             DUMGRIBEX.5     
      SUBROUTINE PBOPEN(INPUT,INPFNAME,SFLAG,ISTAT)                          DUMGRIBEX.6     
      CHARACTER*80 INPFNAME                                                  DUMGRIBEX.7     
      CHARACTER*1 SFLAG                                                      DUMGRIBEX.8     
      RETURN                                                                 DUMGRIBEX.9     
      END                                                                    DUMGRIBEX.10    
C     **********************************************************             DUMGRIBEX.11    
      SUBROUTINE PBCLOSE(INPUT,ISTAT)                                        DUMGRIBEX.12    
      RETURN                                                                 DUMGRIBEX.13    
      END                                                                    DUMGRIBEX.14    
C     **********************************************************             DUMGRIBEX.15    
      SUBROUTINE PBGRIB(ICHAN,INP,ILENB1,ILEN1,ISTAT)                        DUMGRIBEX.16    
      RETURN                                                                 DUMGRIBEX.17    
      END                                                                    DUMGRIBEX.18    
C     **********************************************************             DUMGRIBEX.19    
      SUBROUTINE GRIBEX(ISEC0,ISEC1,ISEC2,ZSEC2,ISEC3,ZSEC3,ISEC4,           DUMGRIBEX.20    
     +     ZSEC4,ILEN4,INP,ILENB,IWORD,OPER,IERR)                            DUMGRIBEX.21    
      RETURN                                                                 DUMGRIBEX.22    
      END                                                                    DUMGRIBEX.23    
C     **********************************************************             DUMGRIBEX.24    
      SUBROUTINE GRPRS0(ISEC0)                                               DUMGRIBEX.25    
      RETURN                                                                 DUMGRIBEX.26    
      END                                                                    DUMGRIBEX.27    
C     **********************************************************             DUMGRIBEX.28    
      SUBROUTINE GRPRS1(ISEC0,ISEC1)                                         DUMGRIBEX.29    
      RETURN                                                                 DUMGRIBEX.30    
      END                                                                    DUMGRIBEX.31    
C     **********************************************************             DUMGRIBEX.32    
      SUBROUTINE GRPRS2(ISEC0,ISEC2,ZSEC2)                                   DUMGRIBEX.33    
      RETURN                                                                 DUMGRIBEX.34    
      END                                                                    DUMGRIBEX.35    
C     **********************************************************             DUMGRIBEX.36    
      SUBROUTINE GRPRS3(ISEC0,ISEC3,ZSEC3)                                   DUMGRIBEX.37    
      RETURN                                                                 DUMGRIBEX.38    
      END                                                                    DUMGRIBEX.39    
C     **********************************************************             DUMGRIBEX.40    
      SUBROUTINE INIGS2                                                      INIGS2.2     
C                                                                            INIGS2.3     
C     Set up for GRIB2 spectral history data (from ECMWF).                   INIGS2.4     
C                                                                            INIGS2.5     
C     GRIB2 code uses the GRIB_API library routines from ECMWF.              INIGS2.6     
C     Note that these libraries will also read GRIB1 data.                   INIGS2.7     
C                                                                            INIGS2.8     
C     Must be used with surfacedata.upd and y2k.upd .                        INIGS2.9     
C                                                                            INIGS2.10    
C     John Methven, University of Reading, 8/9/11.                           INIGS2.11    
C                                                                            INIGS2.12    
C     Changed to calling grib_get_real4_array()                              INIGS2.13    
C     due to default double precision 64-bit compilation on RACC.            INIGS2.14    
C     Also remove explicit declaration of integer*4 and real*8.              INIGS2.15    
C                                                                            INIGS2.16    
C     John Methven, University of Reading, 10/11/20.                         INIGS2.17    
C                                                                            INIGS2.18    
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
      COMMON/COMFFT/NTWG,NRSTWG,TRIG(IDA),WORK(IDF),IFAX(10)                 COMFFT.2     
C                                                                            COMFFT.3     
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
      COMMON/POLYNO/POLYF(NWJ2,NHEM),CMPA(IGL)                               POLYNO.2     
      COMPLEX CMPA                                                           POLYNO.3     
C                                                                            POLYNO.4     
      include 'grib_api_f77.h'                                               INIGS2.26    
c      use grib_api                                                          INIGS2.27    
      INTEGER IREC,IREM,INPFEND                                              INIGS2.28    
      integer iret,ifile,igrib                                               INIGS2.29    
      integer nl_pv,paramId,numberOfValues                                   INIGS2.30    
      PARAMETER(nb_pv=2*NLP)                                                 INIGS2.31    
      real pv(nb_pv)                                                         INIGS2.32    
C                                                                            INIGS2.33    
 6110 FORMAT(/' LATITUDES (DEGREES)'/(15F7.3))                               INIGS2.34    
 6120 FORMAT(/' SIGMA AT HALF LEVELS'/(15F7.4))                              INIGS2.35    
 6130 FORMAT(/' SIGMA AT FULL LEVELS'/(15F7.4))                              INIGS2.36    
 6140 FORMAT(/' PRESSURE AT DATA LEVELS'/(15F7.4))                           INIGS2.37    
C                                                                            INIGS2.38    
C     Determine channel for required GRIB spectral file.                     INIGS2.39    
C     Find filename for channel.                                             INIGS2.40    
C                                                                            INIGS2.41    
      IREC=NINT((DAY-BEGDAY)/THIST)                                          INIGS2.42    
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)                                   INIGS2.43    
      INPFEND=IOFFSET+7                                                      INIGS2.44    
      IF (ISYY.GT.99) INPFEND=IOFFSET+9                                      INIGS2.45    
      IF (IREM.EQ.0) THEN                                                    INIGS2.46    
         CALL MAKENAME(FSTEM,IOFFSET,INPFNAME,NCDATE,LGPQ)                   INIGS2.47    
         call grib_check(grib_open_file(ifile,INPFNAME(1:INPFEND),'r'))      INIGS2.48    
         call grib_check(grib_multi_support_on())                            INIGS2.49    
         PRINT *,INPFNAME(1:INPFEND),' OPENED'                               INIGS2.50    
      ENDIF                                                                  INIGS2.51    
      WRITE(LOUTP,*) ' In INIGS2: ifile, ILEVTYPE = ',ifile,ILEVTYPE         INIGS2.52    
C                                                                            INIGS2.53    
C     Set up levels for vertical scheme.                                     INIGS2.54    
C                                                                            INIGS2.55    
      IF (ILEVTYPE.EQ.0) THEN                                                INIGS2.56    
C                                                                            INIGS2.57    
C     Read ECMWF eta-levels from the GRIB2 file.                             INIGS2.58    
C                                                                            INIGS2.59    
         iret=grib_new_from_file(ifile,igrib)                                INIGS2.60    
	 WRITE(LOUTP,*) ' igrib = ',igrib                                           INIGS2.61    
         call grib_check(grib_get_int(igrib,'paramId',paramId))              INIGS2.62    
	 WRITE(LOUTP,*) ' paramId = ',paramId	                                      INIGS2.63    
         call grib_check(grib_get_size(igrib,'values',numberOfValues))       INIGS2.64    
	 WRITE(LOUTP,*) ' numberOfValues = ',numberOfValues	                        INIGS2.65    
         call grib_check(grib_get_size(igrib,'pv',nl_pv))                    INIGS2.66    
	 WRITE(LOUTP,*) ' nl_pv = ',nl_pv	                                          INIGS2.67    
         if (nl_pv.ne.nb_pv) then                                            INIGS2.68    
            WRITE(LOUTP,*) ' Unexpected number of levels in data'            INIGS2.69    
            WRITE(LOUTP,*) ' Size of input level table = ',nl_pv             INIGS2.70    
            WRITE(LOUTP,*) ' Expected size of level table = ',nb_pv          INIGS2.71    
            STOP                                                             INIGS2.72    
         endif                                                               INIGS2.73    
         call grib_check(grib_get_real4_array(igrib,'pv',pv,nb_pv))          INIGS2.74    
         DO L=1,NLP                                                          INIGS2.75    
            AETA(L)=PV(L)/P0                                                 INIGS2.76    
            BETA(L)=PV(NLP+L)                                                INIGS2.77    
         ENDDO                                                               INIGS2.78    
C                                                                            INIGS2.79    
         CALL INILEV                                                         INIGS2.80    
         WRITE(LOUTP,6120) SIGMAH                                            INIGS2.81    
         WRITE(LOUTP,6130) SIGMA                                             INIGS2.82    
      ENDIF                                                                  INIGS2.83    
      IF (ILEVTYPE.EQ.1) THEN                                                INIGS2.84    
C                                                                            INIGS2.85    
C     Standard pressure levels expected.                                     INIGS2.86    
C     WARNING: incomplete code because no GRIB2 pressure level data!         INIGS2.87    
C                                                                            INIGS2.88    
         DO 100 L=1,NL                                                       INIGS2.89    
            SIGMA(L)=ALEV(L)                                                 INIGS2.90    
 100     CONTINUE                                                            INIGS2.91    
         ALEVH(1)=0.                                                         INIGS2.92    
         ALEVH(NL+1)=0.                                                      INIGS2.93    
         DO 110 L=1,NLM                                                      INIGS2.94    
            ALEVH(L+1)=0.                                                    INIGS2.95    
            SIGMAH(L)=0.                                                     INIGS2.96    
 110     CONTINUE                                                            INIGS2.97    
         WRITE(LOUTP,6140) SIGMA                                             INIGS2.98    
      ENDIF                                                                  INIGS2.99    
C                                                                            INIGS2.100   
C     Close input file.                                                      INIGS2.101   
C                                                                            INIGS2.102   
      IF (IREM.EQ.0) THEN                                                    INIGS2.103   
         call grib_check(grib_release(igrib))                                INIGS2.104   
         call grib_check(grib_close_file(ifile))                             INIGS2.105   
      ENDIF                                                                  INIGS2.106   
C                                                                            INIGS2.107   
C     Derive spectral constants from resolution parameters.                  INIGS2.108   
C                                                                            INIGS2.109   
      MF=MM-1                                                                INIGS2.110   
      MFP=MM                                                                 INIGS2.111   
      MFPP=MM+1                                                              INIGS2.112   
      NF=NN-1                                                                INIGS2.113   
      NFP=NN                                                                 INIGS2.114   
      NFPP=NN+1                                                              INIGS2.115   
C                                                                            INIGS2.116   
C     Spectral arrays for Legendre transforms.                               INIGS2.117   
C                                                                            INIGS2.118   
      SQ(1)=0.                                                               INIGS2.119   
      RSQ(1)=0.                                                              INIGS2.120   
      DO 12 NP=2,NN+2                                                        INIGS2.121   
         SQ(NP)=NP*(NP-1)                                                    INIGS2.122   
         RSQ(NP)=1./SQ(NP)                                                   INIGS2.123   
 12   CONTINUE                                                               INIGS2.124   
C                                                                            INIGS2.125   
C     Set up latitudes.                                                      INIGS2.126   
C     If winds are on a Gaussian grid set up                                 INIGS2.127   
C     Legendre functions also.                                               INIGS2.128   
C                                                                            INIGS2.129   
      CALL INILAT                                                            INIGS2.130   
      WRITE(LOUTP,6110) (ALAT(J)*180./PI,J=JG,1,-1)                          INIGS2.131   
C                                                                            INIGS2.132   
C     Array to calculate x-derivatives of Fourier coefficients.              INIGS2.133   
C                                                                            INIGS2.134   
      DO 20 I=1,IGL                                                          INIGS2.135   
  20  CMPA(I)=0.                                                             INIGS2.136   
      NROW=0                                                                 INIGS2.137   
      DO 30 MP=1,MFP,MOCT                                                    INIGS2.138   
      NROW=NROW+1                                                            INIGS2.139   
      CMPA(NROW)=CMPLX(0.,FLOAT(MP-1))                                       INIGS2.140   
      IF (NHEM.EQ.2) CMPA(NROW+IDL)=CMPA(NROW)                               INIGS2.141   
  30  CONTINUE                                                               INIGS2.142   
C                                                                            INIGS2.143   
C     Normalisation for m=0,n=1 coefficient used to obtain                   INIGS2.144   
C     planetary vorticity.                                                   INIGS2.145   
C                                                                            INIGS2.146   
      EZR=1./SQRT(.75)                                                       INIGS2.147   
C                                                                            INIGS2.148   
C     Set up variables used for FFT99.                                       INIGS2.149   
C                                                                            INIGS2.150   
      CALL SET99(TRIG,IFAX,MG)                                               INIGS2.151   
C                                                                            INIGS2.152   
C     Assume that ECMWF records contain specific humidity.                   INIGS2.153   
C                                                                            INIGS2.154   
      LDRY=.FALSE.                                                           INIGS2.155   
      LGPQ=.FALSE.                                                           INIGS2.156   
C                                                                            INIGS2.157   
      RETURN                                                                 INIGS2.158   
      END                                                                    INIGS2.159   
C     ***************************************************************        INIGS2.160   
      SUBROUTINE GSCOEFFS2                                                   GSCOEFFS2.2     
C                                                                            GSCOEFFS2.3     
C     Read data from GRIB2 spectral files.                                   GSCOEFFS2.4     
C                                                                            GSCOEFFS2.5     
C     Adapted from R.Brugge's Package X.                                     GSCOEFFS2.6     
C     Importantly flat triangular truncation is used.                        GSCOEFFS2.7     
C                                                                            GSCOEFFS2.8     
C     GRIB2 code uses the GRIB_API library routines from ECMWF.              GSCOEFFS2.9     
C                                                                            GSCOEFFS2.10    
C     John Methven, University of Reading, 8/9/11.                           GSCOEFFS2.11    
C                                                                            GSCOEFFS2.12    
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM           PARAMX.2     
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)                             PARAMX.3     
C                                                                            PARAMX.4     
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
      COMMON/RESPECTR/RZ(JPFLSH,NL),RD(JPFLSH,NL),RT(JPFLSH,NL)              RESPECTR.2     
     :,RQ(JPFLSH,NL),RSP(JPFLSH)                                             RESPECTR.3     
C                                                                            RESPECTR.4     
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
C                                                                            GSCOEFFS2.20    
      include 'grib_api_f77.h'                                               GSCOEFFS2.21    
c      use grib_api                                                          GSCOEFFS2.22    
      INTEGER NVAR,INPFEND                                                   GSCOEFFS2.23    
      character*80 paramName                                                 GSCOEFFS2.24    
      integer paramId,numberOfValues                                         GSCOEFFS2.25    
      integer iret,ifile,igrib,icount                                        GSCOEFFS2.26    
      real ZSEC4(JPFLSH)                                                     GSCOEFFS2.27    
C                                                                            GSCOEFFS2.28    
C     Determine channel for required GRIB spectral file.                     GSCOEFFS2.29    
C     Find filename for channel.                                             GSCOEFFS2.30    
C                                                                            GSCOEFFS2.31    
      IREC=NINT((DAY-BEGDAY)/THIST)                                          GSCOEFFS2.32    
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)                                   GSCOEFFS2.33    
      INPFEND=IOFFSET+7                                                      GSCOEFFS2.34    
      IF (ISYY.GT.99) INPFEND=IOFFSET+9                                      GSCOEFFS2.35    
      IF (IREM.EQ.0) THEN                                                    GSCOEFFS2.36    
         CALL MAKENAME(FSTEM,IOFFSET,INPFNAME,NCDATE,LGPQ)                   GSCOEFFS2.37    
         call grib_check(grib_open_file(ifile,INPFNAME(1:INPFEND),'r'))      GSCOEFFS2.38    
         call grib_check(grib_multi_support_on())                            GSCOEFFS2.39    
         PRINT *,INPFNAME(1:INPFEND),' OPENED'                               GSCOEFFS2.40    
      ENDIF                                                                  GSCOEFFS2.41    
      NVAR=3                                                                 GSCOEFFS2.42    
C                                                                            GSCOEFFS2.43    
C     Unpack ln(surface pressure).                                           GSCOEFFS2.44    
C                                                                            GSCOEFFS2.45    
      iret=grib_new_from_file(ifile,igrib)                                   GSCOEFFS2.46    
      call grib_check(grib_get_int(igrib,'paramId',paramId))                 GSCOEFFS2.47    
      IF (paramId.NE.152) THEN                                               GSCOEFFS2.48    
         WRITE(LOUTP,*) 'The first field is not ln(surface pressure).'       GSCOEFFS2.49    
         write(LOUTP,*) 'paramId=',paramId                                   GSCOEFFS2.50    
         call grib_check(grib_get_string(                                    GSCOEFFS2.51    
     :        igrib,'parameterName',paramName))                              GSCOEFFS2.52    
         write(LOUTP,*) 'parameterName=',paramName                           GSCOEFFS2.53    
         STOP                                                                GSCOEFFS2.54    
      ENDIF                                                                  GSCOEFFS2.55    
      call grib_check(grib_get_size(igrib,'values',numberOfValues))          GSCOEFFS2.56    
      IF (numberOfValues.NE.JPFLSH) THEN                                     GSCOEFFS2.57    
         WRITE(LOUTP,*)                                                      GSCOEFFS2.58    
     :  ' First spectral record contains unexpected number of coeffs'        GSCOEFFS2.59    
         WRITE(LOUTP,*) 'numberOfValues=',numberOfValues                     GSCOEFFS2.60    
     :        ,' JPFLSH=',JPFLSH                                             GSCOEFFS2.61    
         STOP                                                                GSCOEFFS2.62    
      ENDIF                                                                  GSCOEFFS2.63    
      call grib_check(grib_get_real4_array(igrib,'values',RSP,JPFLSH))       GSCOEFFS2.64    
      call grib_check(grib_release(igrib))                                   GSCOEFFS2.65    
C                                                                            GSCOEFFS2.66    
C     Loop over NVAR multi-level spectral variables for all levels.          GSCOEFFS2.67    
C                                                                            GSCOEFFS2.68    
      icount=0                                                               GSCOEFFS2.69    
      DO 440 L=1,NL                                                          GSCOEFFS2.70    
         DO 450 IVAR=1,NVAR                                                  GSCOEFFS2.71    
            icount=icount+1                                                  GSCOEFFS2.72    
            iret=grib_new_from_file(ifile,igrib)                             GSCOEFFS2.73    
            if (igrib.eq.-1) then                                            GSCOEFFS2.74    
               if (iret.ne.0) then                                           GSCOEFFS2.75    
                  call grib_check(iret)                                      GSCOEFFS2.76    
               endif                                                         GSCOEFFS2.77    
               WRITE(LOUTP,*) ' End of file reached. icount=',icount         GSCOEFFS2.78    
               stop                                                          GSCOEFFS2.79    
            endif                                                            GSCOEFFS2.80    
C                                                                            GSCOEFFS2.81    
C     Write single level spectral field to appropriate array.                GSCOEFFS2.82    
C     The fields are non-dimensionalised for later grid point                GSCOEFFS2.83    
C     calculations.                                                          GSCOEFFS2.84    
C                                                                            GSCOEFFS2.85    
            call grib_check(grib_get_int(igrib,'paramId',paramId))           GSCOEFFS2.86    
            call grib_check(                                                 GSCOEFFS2.87    
     :           grib_get_real4_array(igrib,'values',ZSEC4,JPFLSH))          GSCOEFFS2.88    
C                                                                            GSCOEFFS2.89    
            IF (paramId.EQ.138) THEN                                         GSCOEFFS2.90    
               DO 300 I=1,JPFLSH                                             GSCOEFFS2.91    
                  RZ(I,L)=ZSEC4(I)/WW                                        GSCOEFFS2.92    
 300           CONTINUE                                                      GSCOEFFS2.93    
            ENDIF                                                            GSCOEFFS2.94    
            IF (paramId.EQ.155) THEN                                         GSCOEFFS2.95    
               DO 310 I=1,JPFLSH                                             GSCOEFFS2.96    
                  RD(I,L)=ZSEC4(I)/WW                                        GSCOEFFS2.97    
 310           CONTINUE                                                      GSCOEFFS2.98    
            ENDIF                                                            GSCOEFFS2.99    
            IF (paramId.EQ.130) THEN                                         GSCOEFFS2.100   
               DO 320 I=1,JPFLSH                                             GSCOEFFS2.101   
                  RT(I,L)=ZSEC4(I)/CT                                        GSCOEFFS2.102   
 320           CONTINUE                                                      GSCOEFFS2.103   
            ENDIF                                                            GSCOEFFS2.104   
            IF (paramId.EQ.133) THEN                                         GSCOEFFS2.105   
               DO 330 I=1,JPFLSH                                             GSCOEFFS2.106   
                  RQ(I,L)=ZSEC4(I)/CQ                                        GSCOEFFS2.107   
 330           CONTINUE                                                      GSCOEFFS2.108   
            ENDIF                                                            GSCOEFFS2.109   
C                                                                            GSCOEFFS2.110   
            call grib_check(grib_release(igrib))                             GSCOEFFS2.111   
 450     CONTINUE                                                            GSCOEFFS2.112   
 440  CONTINUE                                                               GSCOEFFS2.113   
C                                                                            GSCOEFFS2.114   
C     Close input file.                                                      GSCOEFFS2.115   
C                                                                            GSCOEFFS2.116   
      IF (IREM.EQ.NRECPFILE-1) THEN                                          GSCOEFFS2.117   
         call grib_check(grib_close_file(ifile))                             GSCOEFFS2.118   
         write(*,*) 'icount=',icount                                         GSCOEFFS2.119   
      ENDIF                                                                  GSCOEFFS2.120   
C                                                                            GSCOEFFS2.121   
      RETURN                                                                 GSCOEFFS2.122   
      END                                                                    GSCOEFFS2.123   
C     ***************************************************************        GSCOEFFS2.124   
      SUBROUTINE GPQREAD2                                                    GPQREAD2.2     
C                                                                            GPQREAD2.3     
C     Read specific humidity data from GRIB2 Gaussian grid.                  GPQREAD2.4     
C                                                                            GPQREAD2.5     
C     Adapted from R.Brugge's Package X.                                     GPQREAD2.6     
C     GRIB2 code uses the GRIB_API library routines from ECMWF.              GPQREAD2.7     
C                                                                            GPQREAD2.8     
C     John Methven, University of Reading, 8/9/11.                           GPQREAD2.9     
C                                                                            GPQREAD2.10    
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
C                                                                            GPQREAD2.17    
      include 'grib_api_f77.h'                                               GPQREAD2.18    
c      use grib_api                                                          GPQREAD2.19    
      PARAMETER(ILEN4=MG*JGG)                                                GPQREAD2.20    
      INTEGER NVAR,INPFEND                                                   GPQREAD2.21    
      character*80 paramName                                                 GPQREAD2.22    
      integer paramId,numberOfValues                                         GPQREAD2.23    
      integer iret,ifile,igrib,icount                                        GPQREAD2.24    
      real ZSEC4(ILEN4)                                                      GPQREAD2.25    
      DIMENSION QGLA(MG,JGG,NL)                                              GPQREAD2.26    
C                                                                            GPQREAD2.27    
C     Determine channel for required GRIB grid point file.                   GPQREAD2.28    
C     Find filename for channel.                                             GPQREAD2.29    
C                                                                            GPQREAD2.30    
      IREC=NINT((DAY-BEGDAY)/THIST)                                          GPQREAD2.31    
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)                                   GPQREAD2.32    
      INPFEND=IOFFSET+7                                                      GPQREAD2.33    
      IF (ISYY.GT.99) INPFEND=IOFFSET+9                                      GPQREAD2.34    
      IF (IREM.EQ.0) THEN                                                    GPQREAD2.35    
         CALL MAKENAME(FSTEM2,IOFFSET,INPFNAME,NCDATE,LGPQ)                  GPQREAD2.36    
         call grib_check(grib_open_file(ifile,INPFNAME(1:INPFEND),'r'))      GPQREAD2.37    
         call grib_check(grib_multi_support_on())                            GPQREAD2.38    
         PRINT *,INPFNAME(1:INPFEND),' OPENED'                               GPQREAD2.39    
      ENDIF                                                                  GPQREAD2.40    
C                                                                            GPQREAD2.41    
C     Unpack specific humidity data.                                         GPQREAD2.42    
C                                                                            GPQREAD2.43    
      icount=0                                                               GPQREAD2.44    
      DO 10 L=1,NL                                                           GPQREAD2.45    
         icount=icount+1                                                     GPQREAD2.46    
         iret=grib_new_from_file(ifile,igrib)                                GPQREAD2.47    
         call grib_check(grib_get_size(igrib,'values',numberOfValues))       GPQREAD2.48    
         IF (numberOfValues.NE.ILEN4) THEN                                   GPQREAD2.49    
            WRITE(LOUTP,*)                                                   GPQREAD2.50    
     :     ' First gridded record contains unexpected number of points'      GPQREAD2.51    
            WRITE(LOUTP,*) 'numberOfValues=',numberOfValues                  GPQREAD2.52    
     :           ,' ILEN4=',ILEN4                                            GPQREAD2.53    
            STOP                                                             GPQREAD2.54    
         ENDIF                                                               GPQREAD2.55    
         call grib_check(grib_get_int(igrib,'paramId',paramId))              GPQREAD2.56    
         IF (paramId.NE.133) THEN                                            GPQREAD2.57    
            WRITE(LOUTP,*) 'The field is not specific humidity.'             GPQREAD2.58    
            write(LOUTP,*) 'paramId=',paramId                                GPQREAD2.59    
            call grib_check(grib_get_string(                                 GPQREAD2.60    
     :           igrib,'parameterName',paramName))                           GPQREAD2.61    
            write(LOUTP,*) 'parameterName=',paramName                        GPQREAD2.62    
            STOP                                                             GPQREAD2.63    
         ENDIF                                                               GPQREAD2.64    
         call grib_check(                                                    GPQREAD2.65    
     :        grib_get_real4_array(igrib,'values',ZSEC4,ILEN4))              GPQREAD2.66    
         II=0                                                                GPQREAD2.67    
         DO 20 J=1,JGG                                                       GPQREAD2.68    
            DO 30 I=1,MG                                                     GPQREAD2.69    
               II=II+1                                                       GPQREAD2.70    
               QGLA(I,J,L)=ZSEC4(II)                                         GPQREAD2.71    
 30         CONTINUE                                                         GPQREAD2.72    
 20      CONTINUE                                                            GPQREAD2.73    
         call grib_check(grib_release(igrib))                                GPQREAD2.74    
 10   CONTINUE                                                               GPQREAD2.75    
C                                                                            GPQREAD2.76    
C     Close input file.                                                      GPQREAD2.77    
C                                                                            GPQREAD2.78    
      IF (IREM.EQ.0) THEN                                                    GPQREAD2.79    
         call grib_check(grib_close_file(ifile))                             GPQREAD2.80    
         write(*,*) 'icount=',icount                                         GPQREAD2.81    
      ENDIF                                                                  GPQREAD2.82    
C                                                                            GPQREAD2.83    
C     Write specific humidity to a scratch file.                             GPQREAD2.84    
C                                                                            GPQREAD2.85    
      INORTH=0                                                               GPQREAD2.86    
      ISOUTH=MGPP                                                            GPQREAD2.87    
      DO 40 J=1,JG                                                           GPQREAD2.88    
         JSOUTH=JGGP-J                                                       GPQREAD2.89    
         DO 50 L=1,NL                                                        GPQREAD2.90    
            LL=(L-1)*IGC                                                     GPQREAD2.91    
            DO 60 I=1,MG                                                     GPQREAD2.92    
               QG(LL+INORTH+I)=QGLA(I,J,L)                                   GPQREAD2.93    
               QG(LL+ISOUTH+I)=QGLA(I,JSOUTH,L)                              GPQREAD2.94    
 60         CONTINUE                                                         GPQREAD2.95    
 50      CONTINUE                                                            GPQREAD2.96    
         WRITE(NCGP(4)) QG                                                   GPQREAD2.97    
 40   CONTINUE                                                               GPQREAD2.98    
C                                                                            GPQREAD2.99    
      RETURN                                                                 GPQREAD2.100   
      END                                                                    GPQREAD2.101   
C     ***************************************************************        GPQREAD2.102   
      SUBROUTINE READSFC2                                                    READSFC2.2     
C                                                                            READSFC2.3     
C     Read surface field data from GRIB2 Gaussian grid.                      READSFC2.4     
C     Longitude-latitude ordering as for surface pressure transformed        READSFC2.5     
C     from spectral data.                                                    READSFC2.6     
C                                                                            READSFC2.7     
C     NVAR=number of surface fields in each file.                            READSFC2.8     
C                                                                            READSFC2.9     
C     Adapted from R.Brugge's Package X.                                     READSFC2.10    
C     GRIB2 code uses the GRIB_API library routines from ECMWF.              READSFC2.11    
C                                                                            READSFC2.12    
C     John Methven, University of Reading, 8/9/11.                           READSFC2.13    
C                                                                            READSFC2.14    
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
C                                                                            READSFC2.21    
      include 'grib_api_f77.h'                                               READSFC2.22    
c      use grib_api                                                          READSFC2.23    
      PARAMETER(ILEN4=MG*JGG)                                                READSFC2.24    
      INTEGER NVAR,INPFEND                                                   READSFC2.25    
      INTEGER IVAR,KLEV,ISOUTH,JNORTH,JSOUTH                                 READSFC2.26    
      character*80 paramName                                                 READSFC2.27    
      integer paramId,numberOfValues                                         READSFC2.28    
      integer iret,ifile,igrib                                               READSFC2.29    
      real ZSEC4(ILEN4)                                                      READSFC2.30    
      DIMENSION QGLA(MG,JGG,NL)                                              READSFC2.31    
C                                                                            READSFC2.32    
C     Determine channel for required GRIB grid point file.                   READSFC2.33    
C     Find filename for channel.                                             READSFC2.34    
C                                                                            READSFC2.35    
      IREC=NINT((DAY-BEGDAY)/THIST)                                          READSFC2.36    
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)                                   READSFC2.37    
      INPFEND=IOFFSET+7                                                      READSFC2.38    
      IF (ISYY.GT.99) INPFEND=IOFFSET+9                                      READSFC2.39    
      IF (IREM.EQ.0) THEN                                                    READSFC2.40    
         CALL MAKENAME(FSTEM3,IOFFSET,INPFNAME,NCDATE,LGPQ)                  READSFC2.41    
         call grib_check(grib_open_file(ifile,INPFNAME(1:INPFEND),'r'))      READSFC2.42    
         call grib_check(grib_multi_support_on())                            READSFC2.43    
         PRINT *,INPFNAME(1:INPFEND),' OPENED'                               READSFC2.44    
      ENDIF                                                                  READSFC2.45    
C                                                                            READSFC2.46    
C     Number of surface fields to be read from file.                         READSFC2.47    
C                                                                            READSFC2.48    
C                                                                            SFCDATA.322   
C        Reset NVAR to the number of variables in each surface file          SFCDATA.323   
C                                                                            SFCDATA.324   
         NVAR=1                                                              SFCDATA.325   
C                                                                            READSFC2.50    
C     Unpack surface data.                                                   READSFC2.51    
C                                                                            READSFC2.52    
      ISOUTH=MGPP                                                            READSFC2.53    
      DO 10 IVAR=1,NVAR                                                      READSFC2.54    
         iret=grib_new_from_file(ifile,igrib)                                READSFC2.55    
         call grib_check(grib_get_size(igrib,'values',numberOfValues))       READSFC2.56    
         IF (numberOfValues.NE.ILEN4) THEN                                   READSFC2.57    
            WRITE(LOUTP,*)                                                   READSFC2.58    
     :     ' First gridded record contains unexpected number of points'      READSFC2.59    
            WRITE(LOUTP,*) 'numberOfValues=',numberOfValues                  READSFC2.60    
     :           ,' ILEN4=',ILEN4                                            READSFC2.61    
            STOP                                                             READSFC2.62    
         ENDIF                                                               READSFC2.63    
         call grib_check(grib_get_int(igrib,'paramId',paramId))              READSFC2.64    
                                                                             READSFC2.65    
         call grib_check(grib_get_string(                                    READSFC2.66    
     :           igrib,'parameterName',paramName))                           READSFC2.67    
         write(LOUTP,*) 'Found parameterName=',paramName                     READSFC2.68    
         call grib_check(                                                    READSFC2.69    
     :        grib_get_real4_array(igrib,'values',ZSEC4,ILEN4))              READSFC2.70    
C                                                                            READSFC2.71    
         IF (paramId.EQ.142) THEN                                            READSFC2.72    
            WRITE(LOUTP,*) '  Stratiform precipitation has been read.'       READSFC2.73    
            DO J=1,JG                                                        READSFC2.74    
               JNORTH=(J-1)*MG                                               READSFC2.75    
               JSOUTH=(JGG-J)*MG                                             READSFC2.76    
               DO I=1,MG                                                     READSFC2.77    
                  PRECST(I,J)=ZSEC4(JNORTH+I)                                READSFC2.78    
                  PRECST(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                         READSFC2.79    
               ENDDO                                                         READSFC2.80    
            ENDDO                                                            READSFC2.81    
         ENDIF                                                               READSFC2.82    
         IF (paramId.EQ.143) THEN                                            READSFC2.83    
            WRITE(LOUTP,*) '  Convective precipitation has been read.'       READSFC2.84    
            DO J=1,JG                                                        READSFC2.85    
               JNORTH=(J-1)*MG                                               READSFC2.86    
               JSOUTH=(JGG-J)*MG                                             READSFC2.87    
               DO I=1,MG                                                     READSFC2.88    
                  PRECIP(I,J)=ZSEC4(JNORTH+I)                                READSFC2.89    
                  PRECIP(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                         READSFC2.90    
               ENDDO                                                         READSFC2.91    
            ENDDO                                                            READSFC2.92    
         ENDIF                                                               READSFC2.93    
         IF (paramId.EQ.159) THEN                                            READSFC2.94    
            WRITE(LOUTP,*) '  BL height has been read.'                      READSFC2.95    
            DO J=1,JG                                                        READSFC2.96    
               JNORTH=(J-1)*MG                                               READSFC2.97    
               JSOUTH=(JGG-J)*MG                                             READSFC2.98    
               DO I=1,MG                                                     READSFC2.99    
                  BLHEIGHT(I,J)=ZSEC4(JNORTH+I)                              READSFC2.100   
                  BLHEIGHT(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                       READSFC2.101   
               ENDDO                                                         READSFC2.102   
            ENDDO                                                            READSFC2.103   
         ENDIF                                                               READSFC2.104   
         IF (paramId.EQ.167) THEN                                            READSFC2.105   
            WRITE(LOUTP,*) '  T (2m) has been read.'                         READSFC2.106   
            DO J=1,JG                                                        READSFC2.107   
               JNORTH=(J-1)*MG                                               READSFC2.108   
               JSOUTH=(JGG-J)*MG                                             READSFC2.109   
               DO I=1,MG                                                     READSFC2.110   
                  TEMP2M(I,J)=ZSEC4(JNORTH+I)                                READSFC2.111   
                  TEMP2M(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                         READSFC2.112   
               ENDDO                                                         READSFC2.113   
            ENDDO                                                            READSFC2.114   
         ENDIF                                                               READSFC2.115   
         IF (paramId.EQ.168) THEN                                            READSFC2.116   
            WRITE(LOUTP,*) '  T_dew (2m) has been read.'                     READSFC2.117   
            DO J=1,JG                                                        READSFC2.118   
               JNORTH=(J-1)*MG                                               READSFC2.119   
               JSOUTH=(JGG-J)*MG                                             READSFC2.120   
               DO I=1,MG                                                     READSFC2.121   
                  TDEW2M(I,J)=ZSEC4(JNORTH+I)                                READSFC2.122   
                  TDEW2M(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                         READSFC2.123   
               ENDDO                                                         READSFC2.124   
            ENDDO                                                            READSFC2.125   
         ENDIF                                                               READSFC2.126   
         IF (paramId.EQ.182) THEN                                            READSFC2.127   
            WRITE(LOUTP,*) '  Evaporation has been read.'                    READSFC2.128   
            DO J=1,JG                                                        READSFC2.129   
               JNORTH=(J-1)*MG                                               READSFC2.130   
               JSOUTH=(JGG-J)*MG                                             READSFC2.131   
               DO I=1,MG                                                     READSFC2.132   
                  EVAP(I,J)=ZSEC4(JNORTH+I)                                  READSFC2.133   
                  EVAP(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                           READSFC2.134   
               ENDDO                                                         READSFC2.135   
            ENDDO                                                            READSFC2.136   
         ENDIF                                                               READSFC2.137   
         IF (paramId.EQ.186) THEN                                            READSFC2.138   
            WRITE(LOUTP,*) '  Low level cloud has been read.'                READSFC2.139   
            DO J=1,JG                                                        READSFC2.140   
               JNORTH=(J-1)*MG                                               READSFC2.141   
               JSOUTH=(JGG-J)*MG                                             READSFC2.142   
               DO I=1,MG                                                     READSFC2.143   
                  ALLC(I,J)=ZSEC4(JNORTH+I)                                  READSFC2.144   
                  ALLC(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                           READSFC2.145   
               ENDDO                                                         READSFC2.146   
            ENDDO                                                            READSFC2.147   
         ENDIF                                                               READSFC2.148   
         IF (paramId.EQ.187) THEN                                            READSFC2.149   
            WRITE(LOUTP,*) '  Medium level cloud has been read.'             READSFC2.150   
            DO J=1,JG                                                        READSFC2.151   
               JNORTH=(J-1)*MG                                               READSFC2.152   
               JSOUTH=(JGG-J)*MG                                             READSFC2.153   
               DO I=1,MG                                                     READSFC2.154   
                  AMLC(I,J)=ZSEC4(JNORTH+I)                                  READSFC2.155   
                  AMLC(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                           READSFC2.156   
               ENDDO                                                         READSFC2.157   
            ENDDO                                                            READSFC2.158   
         ENDIF                                                               READSFC2.159   
         IF (paramId.EQ.188) THEN                                            READSFC2.160   
            WRITE(LOUTP,*) '  High level cloud has been read.'               READSFC2.161   
            DO J=1,JG                                                        READSFC2.162   
               JNORTH=(J-1)*MG                                               READSFC2.163   
               JSOUTH=(JGG-J)*MG                                             READSFC2.164   
               DO I=1,MG                                                     READSFC2.165   
                  AHLC(I,J)=ZSEC4(JNORTH+I)                                  READSFC2.166   
                  AHLC(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                           READSFC2.167   
               ENDDO                                                         READSFC2.168   
            ENDDO                                                            READSFC2.169   
         ENDIF                                                               READSFC2.170   
         IF (paramId.EQ.58) THEN                                             READSFC2.171   
            WRITE(LOUTP,*) '  PAR has been read.'                            READSFC2.172   
            DO J=1,JG                                                        READSFC2.173   
               JNORTH=(J-1)*MG                                               READSFC2.174   
               JSOUTH=(JGG-J)*MG                                             READSFC2.175   
               DO I=1,MG                                                     READSFC2.176   
                  PCRAD(I,J)=ZSEC4(JNORTH+I)                                 READSFC2.177   
                  PCRAD(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                          READSFC2.178   
               ENDDO                                                         READSFC2.179   
            ENDDO                                                            READSFC2.180   
         ENDIF                                                               READSFC2.181   
         call grib_check(grib_release(igrib))                                READSFC2.182   
 10   CONTINUE                                                               READSFC2.183   
C                                                                            READSFC2.184   
C     Close input file.                                                      READSFC2.185   
C                                                                            READSFC2.186   
      IF (IREM.EQ.0) THEN                                                    READSFC2.187   
         call grib_check(grib_close_file(ifile))                             READSFC2.188   
      ENDIF                                                                  READSFC2.189   
C                                                                            READSFC2.190   
      RETURN                                                                 READSFC2.191   
      END                                                                    READSFC2.192   
C     ***************************************************************        READSFC2.193   
      SUBROUTINE DENSCALC                                                    DENSCALC.2     
C                                                                            DENSCALC.3     
C     Calculate (pg/RT)*(d(eta)/dp) on full levels.                          DENSCALC.4     
C     Used to integrate hydrostatic equation to find height.                 DENSCALC.5     
C                                                                            DENSCALC.6     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/LEGAU/                                                          LEGAU.2     
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)       LEGAU.3     
     :,JH,JL                                                                 LEGAU.4     
C                                                                            LEGAU.5     
      INTEGER L,IHEM,I,JJ,LL,IOF,II                                          DENSCALC.12    
      REAL DETA                                                              DENSCALC.13    
C                                                                            DENSCALC.14    
      JJ=(JL-1)*IGD                                                          DENSCALC.15    
      DO L=1,NL                                                              DENSCALC.16    
         LL=(L-1)*IGC                                                        DENSCALC.17    
         DETA=(ALEVH(L+1)-ALEVH(L))*GA/RDGAS                                 DENSCALC.18    
         DO IHEM=1,NHEM                                                      DENSCALC.19    
            IOF=(IHEM-1)*MGPP                                                DENSCALC.20    
            DO I=1,MG                                                        DENSCALC.21    
               II=IOF+I                                                      DENSCALC.22    
               W2ETA(JJ+LL+II)=DETA*PSG(II,L)                                DENSCALC.23    
     :                     /(CT*TG(LL+II)*(PSGH(II,L+1)-PSGH(II,L)))         DENSCALC.24    
            ENDDO                                                            DENSCALC.25    
         ENDDO                                                               DENSCALC.26    
      ENDDO                                                                  DENSCALC.27    
C                                                                            DENSCALC.28    
      RETURN                                                                 DENSCALC.29    
      END                                                                    DENSCALC.30    
C     *****************************************************************      DENSCALC.31    
      SUBROUTINE READSFC                                                     READSFC.2     
C                                                                            READSFC.3     
C     Read surface field data from GRIB Gaussian grid.                       READSFC.4     
C     Longitude-latitude ordering as for surface pressure transformed        READSFC.5     
C     from spectral data.                                                    READSFC.6     
C                                                                            READSFC.7     
C     NVAR=number of surface fields in each file.                            READSFC.8     
C                                                                            READSFC.9     
C     Adapted from R.Brugge's Package X.                                     READSFC.10    
C                                                                            READSFC.11    
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2                      CHANS.2     
     :,NCINTRAJ,NCGP(MAXATTR)                                                CHANS.3     
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT                                CHANS.4     
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME                                          CHANS.5     
     :,FSTEM3                                                                SFCDATA.1     
      LOGICAL LPOUT,LEVERY                                                   CHANS.6     
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME                              CHANS.7     
     :,FSTEM3                                                                SFCDATA.2     
C                                                                            CHANS.8     
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD              TIMEV.2     
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE                               TIMEV.3     
     :,KYY,KMM,KDD,KHH,IDATE,IGRIBV                                          SFCDATA.3     
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                          TIMEV.4     
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP                                          TIMEV.5     
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)                             TIMEV.6     
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET                                 TIMEV.7     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.8     
     :,LSFCATTR,LFORC                                                        SFCDATA.4     
     :,LYRNAM                                                                Y2K.1     
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST                   TIMEV.9     
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR                                  TIMEV.10    
     :,LSFCATTR,LFORC                                                        SFCDATA.5     
     :,LYRNAM                                                                Y2K.2     
C                                                                            TIMEV.11    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
C                                                                            READSFC.18    
      PARAMETER(ILEN4=MG*JGG)                                                READSFC.19    
      INTEGER INPFEND,IFIELD,IVAR,NVAR,KLEV,ISOUTH,JNORTH,JSOUTH             READSFC.20    
      DIMENSION ZSEC4(ILEN4)                                                 READSFC.21    
C                                                                            READSFC.22    
C     Number of surface fields to be read from file.                         READSFC.23    
C                                                                            READSFC.24    
      NVAR=3                                                                 READSFC.25    
C                                                                            READSFC.26    
C     Determine channel for required GRIB surface file.                      READSFC.27    
C     Find filename for channel.                                             READSFC.28    
C                                                                            READSFC.29    
      IREC=NINT((DAY-BEGDAY)/THIST)                                          READSFC.30    
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)                                   READSFC.31    
      INPFEND=IOFFSET+7                                                      READSFC.32    
      IF (ISYY.GT.99) INPFEND=IOFFSET+9                                      READSFC.33    
      IF (IREM.EQ.0) THEN                                                    READSFC.34    
         CALL MAKENAME(FSTEM3,IOFFSET,INPFNAME,NCDATE,LGPQ)                  READSFC.35    
         WRITE(LOUTP,*) 'Assuming file ',INPFNAME(1:INPFEND)                 READSFC.36    
     :        ,' is Cray unblocked'                                          READSFC.37    
         ISTAT=0                                                             READSFC.38    
C                                                                            READSFC.39    
C     Note that PBOPEN will change the channel number INPUT2.                READSFC.40    
C                                                                            READSFC.41    
         CALL PBOPEN(INPUT2,INPFNAME(1:INPFEND),'r',ISTAT)                   READSFC.42    
         IF(ISTAT.NE.0) THEN                                                 READSFC.43    
            WRITE(LOUTP,*) 'Error opening file ',INPFNAME(1:INPFEND)         READSFC.44    
            WRITE(LOUTP,*) 'PBOPEN returns ISTAT = ',ISTAT                   READSFC.45    
            CALL ABORT                                                       READSFC.46    
         ELSE                                                                READSFC.47    
            PRINT *,INPFNAME(1:INPFEND),' OPENED'                            READSFC.48    
         ENDIF                                                               READSFC.49    
      ENDIF                                                                  READSFC.50    
C                                                                            READSFC.51    
C     Unpack surface data.                                                   READSFC.52    
C                                                                            READSFC.53    
      ISOUTH=MGPP                                                            READSFC.54    
      DO 10 IVAR=1,NVAR                                                      READSFC.55    
         CALL SPUNPACK(ZSEC4,ILEN4,INPUT2,IFIELD,KLEV)                       READSFC.56    
         IF (IFIELD.EQ.142) THEN                                             READSFC.57    
            WRITE(LOUTP,*) '  Stratiform precipitation has been read.'       READSFC.58    
            DO J=1,JG                                                        READSFC.59    
               JNORTH=(J-1)*MG                                               READSFC.60    
               JSOUTH=(JGG-J)*MG                                             READSFC.61    
               DO I=1,MG                                                     READSFC.62    
                  PRECST(I,J)=ZSEC4(JNORTH+I)                                READSFC.63    
                  PRECST(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                         READSFC.64    
               ENDDO                                                         READSFC.65    
            ENDDO                                                            READSFC.66    
         ENDIF                                                               READSFC.67    
         IF (IFIELD.EQ.143) THEN                                             READSFC.68    
            WRITE(LOUTP,*) '  Convective precipitation has been read.'       READSFC.69    
            DO J=1,JG                                                        READSFC.70    
               JNORTH=(J-1)*MG                                               READSFC.71    
               JSOUTH=(JGG-J)*MG                                             READSFC.72    
               DO I=1,MG                                                     READSFC.73    
                  PRECIP(I,J)=ZSEC4(JNORTH+I)                                READSFC.74    
                  PRECIP(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                         READSFC.75    
               ENDDO                                                         READSFC.76    
            ENDDO                                                            READSFC.77    
         ENDIF                                                               READSFC.78    
         IF (IFIELD.EQ.159) THEN                                             READSFC.79    
            WRITE(LOUTP,*) '  BL height has been read.'                      READSFC.80    
            DO J=1,JG                                                        READSFC.81    
               JNORTH=(J-1)*MG                                               READSFC.82    
               JSOUTH=(JGG-J)*MG                                             READSFC.83    
               DO I=1,MG                                                     READSFC.84    
                  BLHEIGHT(I,J)=ZSEC4(JNORTH+I)                              READSFC.85    
                  BLHEIGHT(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                       READSFC.86    
               ENDDO                                                         READSFC.87    
            ENDDO                                                            READSFC.88    
         ENDIF                                                               READSFC.89    
         IF (IFIELD.EQ.167) THEN                                             READSFC.90    
            WRITE(LOUTP,*) '  T (2m) has been read.'                         READSFC.91    
            DO J=1,JG                                                        READSFC.92    
               JNORTH=(J-1)*MG                                               READSFC.93    
               JSOUTH=(JGG-J)*MG                                             READSFC.94    
               DO I=1,MG                                                     READSFC.95    
                  TEMP2M(I,J)=ZSEC4(JNORTH+I)                                READSFC.96    
                  TEMP2M(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                         READSFC.97    
               ENDDO                                                         READSFC.98    
            ENDDO                                                            READSFC.99    
         ENDIF                                                               READSFC.100   
         IF (IFIELD.EQ.168) THEN                                             READSFC.101   
            WRITE(LOUTP,*) '  T_dew (2m) has been read.'                     READSFC.102   
            DO J=1,JG                                                        READSFC.103   
               JNORTH=(J-1)*MG                                               READSFC.104   
               JSOUTH=(JGG-J)*MG                                             READSFC.105   
               DO I=1,MG                                                     READSFC.106   
                  TDEW2M(I,J)=ZSEC4(JNORTH+I)                                READSFC.107   
                  TDEW2M(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                         READSFC.108   
               ENDDO                                                         READSFC.109   
            ENDDO                                                            READSFC.110   
         ENDIF                                                               READSFC.111   
         IF (IFIELD.EQ.182) THEN                                             READSFC.112   
            WRITE(LOUTP,*) '  Evaporation has been read.'                    READSFC.113   
            DO J=1,JG                                                        READSFC.114   
               JNORTH=(J-1)*MG                                               READSFC.115   
               JSOUTH=(JGG-J)*MG                                             READSFC.116   
               DO I=1,MG                                                     READSFC.117   
                  EVAP(I,J)=ZSEC4(JNORTH+I)                                  READSFC.118   
                  EVAP(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                           READSFC.119   
               ENDDO                                                         READSFC.120   
            ENDDO                                                            READSFC.121   
         ENDIF                                                               READSFC.122   
         IF (IFIELD.EQ.186) THEN                                             READSFC.123   
            WRITE(LOUTP,*) '  Low level cloud has been read.'                READSFC.124   
            DO J=1,JG                                                        READSFC.125   
               JNORTH=(J-1)*MG                                               READSFC.126   
               JSOUTH=(JGG-J)*MG                                             READSFC.127   
               DO I=1,MG                                                     READSFC.128   
                  ALLC(I,J)=ZSEC4(JNORTH+I)                                  READSFC.129   
                  ALLC(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                           READSFC.130   
               ENDDO                                                         READSFC.131   
            ENDDO                                                            READSFC.132   
         ENDIF                                                               READSFC.133   
         IF (IFIELD.EQ.187) THEN                                             READSFC.134   
            WRITE(LOUTP,*) '  Medium level cloud has been read.'             READSFC.135   
            DO J=1,JG                                                        READSFC.136   
               JNORTH=(J-1)*MG                                               READSFC.137   
               JSOUTH=(JGG-J)*MG                                             READSFC.138   
               DO I=1,MG                                                     READSFC.139   
                  AMLC(I,J)=ZSEC4(JNORTH+I)                                  READSFC.140   
                  AMLC(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                           READSFC.141   
               ENDDO                                                         READSFC.142   
            ENDDO                                                            READSFC.143   
         ENDIF                                                               READSFC.144   
         IF (IFIELD.EQ.188) THEN                                             READSFC.145   
            WRITE(LOUTP,*) '  High level cloud has been read.'               READSFC.146   
            DO J=1,JG                                                        READSFC.147   
               JNORTH=(J-1)*MG                                               READSFC.148   
               JSOUTH=(JGG-J)*MG                                             READSFC.149   
               DO I=1,MG                                                     READSFC.150   
                  AHLC(I,J)=ZSEC4(JNORTH+I)                                  READSFC.151   
                  AHLC(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                           READSFC.152   
               ENDDO                                                         READSFC.153   
            ENDDO                                                            READSFC.154   
         ENDIF                                                               READSFC.155   
         IF (IFIELD.EQ.58) THEN                                              READSFC.156   
            WRITE(LOUTP,*) '  PAR has been read.'                            READSFC.157   
            DO J=1,JG                                                        READSFC.158   
               JNORTH=(J-1)*MG                                               READSFC.159   
               JSOUTH=(JGG-J)*MG                                             READSFC.160   
               DO I=1,MG                                                     READSFC.161   
                  PCRAD(I,J)=ZSEC4(JNORTH+I)                                 READSFC.162   
                  PCRAD(ISOUTH+I,J)=ZSEC4(JSOUTH+I)                          READSFC.163   
               ENDDO                                                         READSFC.164   
            ENDDO                                                            READSFC.165   
         ENDIF                                                               READSFC.166   
 10   CONTINUE                                                               READSFC.167   
C                                                                            READSFC.168   
C     Close input file.                                                      READSFC.169   
C                                                                            READSFC.170   
      IF (IREM.EQ.0) THEN                                                    READSFC.171   
         ISTAT=0                                                             READSFC.172   
         CALL PBCLOSE(INPUT2,ISTAT)                                          READSFC.173   
         IF(ISTAT.NE.0) THEN                                                 READSFC.174   
            WRITE(LOUTP,*) 'ERROR CLOSING FILE ',INPFNAME                    READSFC.175   
            WRITE(LOUTP,*) 'ISTAT = ',ISTAT                                  READSFC.176   
            CALL ABORT                                                       READSFC.177   
         ENDIF                                                               READSFC.178   
      ENDIF                                                                  READSFC.179   
C                                                                            READSFC.180   
      RETURN                                                                 READSFC.181   
      END                                                                    READSFC.182   
C     ***************************************************************        READSFC.183   
      SUBROUTINE ETABLCALC                                                   ETABL.2     
C                                                                            ETABL.3     
C     Calculate eta at the top of the BL, given BL height.                   ETABL.4     
C     Assumes that the subroutine DENSCALC has already been run.             ETABL.5     
C                                                                            ETABL.6     
C                                                                            JOBID.6     
C     Do NOT set NTRAC=0 since some arrays will then have zero length.       JOBID.7     
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .       JOBID.8     
C                                                                            JOBID.9     
      PARAMETER(NN=255,MM=255,NHEM=2,NL=137,MOCT=1,MG=512,JG=128             JOBID.10    
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=53792,IPTS=5                          JOBID.11    
     P  ,NATTR=5,MAXCLUS=100)                                                JOBID.12    
C                                                                            PARAM1.4     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT               PARAM2.2     
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2               PARAM2.3     
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT                PARAM2.4     
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG                       PARAM2.5     
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL                     PARAM2.6     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC                               PARAM2.7     
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC               PARAM2.8     
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)                                       PARAM2.9     
C                                                                            PARAM2.10    
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)                 BLANK.2     
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV                                BLANK.3     
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)                                           BLANK.4     
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)                              BLANK.5     
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)                    BLANK.6     
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS                                      BLANK.7     
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)                               BLANK.8     
     :,MF,MFP,NF,NFP,MFPP,NFPP                                               BLANK.9     
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ                        BLANK.10    
      COMPLEX EZ                                                             BLANK.11    
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ                                       BLANK.12    
C                                                                            BLANK.13    
C                                                                            GRIDP.2     
C     UG->PMG equivalenced in the subroutines                                GRIDP.3     
C     GSP2GRID and RSP2GRID. Do NOT change their order.                      GRIDP.4     
C                                                                            GRIDP.5     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)                   GRIDP.6     
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)                          GRIDP.7     
     :,TRAG(IGDT),SDOTG(IGD)                                                 GRIDP.8     
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)                 GRIDP.9     
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)                                  GRIDP.10    
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)                                        GRIDP.11    
     :,W2ETA(IGDLA)                                                          ZATTR.1     
     :,THGLA(IGDLA),PLGLA(IGC,JG)                                            GRIDP.12    
     :,PRECIP(IGC,JG),PRECST(IGC,JG),BLHEIGHT(IGC,JG),BLETA(IGC,JG)          SFCDATA.6     
     :,PRECIP6HR(IGC,JG),PRECST6HR(IGC,JG),PCRAD6HR(IGC,JG)                  SFCDATA.7     
     :,ALLC(IGC,JG),AMLC(IGC,JG),AHLC(IGC,JG)                                SFCDATA.8     
     :,TEMP2M(IGC,JG),TDEW2M(IGC,JG),PCRAD(IGC,JG)                           SFCDATA.9     
     :,PRECIPM(IGC,JG),PRECSTM(IGC,JG),BLHEIGHTM(IGC,JG)                     SFCDATA.10    
     :,ALLCM(IGC,JG),AMLCM(IGC,JG),AHLCM(IGC,JG)                             SFCDATA.11    
     :,TEMP2MM(IGC,JG),TDEW2MM(IGC,JG),PCRADM(IGC,JG)                        SFCDATA.12    
     :,EVAP(IGC,JG),EVAP6HR(IGC,JG),EVAPM(IGC,JG)                            SFCDATA.13    
C                                                                            GRIDP.13    
      COMMON/LEGAU/                                                          LEGAU.2     
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)       LEGAU.3     
     :,JH,JL                                                                 LEGAU.4     
C                                                                            LEGAU.5     
      INTEGER L,IHEM,I,JJ,LL,IOF,II                                          ETABL.12    
      REAL W2EARR(NL),ZARR(NL),DETA,BLZ,BLE,BOUND                            ETABL.13    
C                                                                            ETABL.14    
      BOUND=1.                                                               ETABL.15    
      JJ=(JL-1)*IGD                                                          ETABL.16    
      DO IHEM=1,NHEM                                                         ETABL.17    
         IOF=(IHEM-1)*MGPP                                                   ETABL.18    
         DO I=1,MG                                                           ETABL.19    
            II=IOF+I                                                         ETABL.20    
            BLZ=BLHEIGHT(II,JL)                                              ETABL.21    
            DO L=1,NL                                                        ETABL.22    
               LL=(L-1)*IGC                                                  ETABL.23    
               W2EARR(L)=1./W2ETA(JJ+LL+II)                                  ETABL.24    
            ENDDO                                                            ETABL.25    
C                                                                            ETABL.26    
C     Vertical integral to find height (m) on each model level using         ETABL.27    
C     Trapezium rule and linearly interpolate to find eta_BL.                ETABL.28    
C                                                                            ETABL.29    
            BLE=0.                                                           ETABL.30    
            ZARR(NL)=W2EARR(NL)*(BOUND-ALEV(NL))                             ETABL.31    
            L=NL-1                                                           ETABL.32    
            DO WHILE (L.GT.0)                                                ETABL.33    
               DETA=ALEV(L+1)-ALEV(L)                                        ETABL.34    
               ZARR(L)=ZARR(L+1)+0.5*(W2EARR(L+1)+W2EARR(L))*DETA            ETABL.35    
               IF (ZARR(L).GT.BLZ) THEN                                      ETABL.36    
                  BLE=ALEV(L)+(BLZ-ZARR(L))*DETA/(ZARR(L+1)-ZARR(L))         ETABL.37    
                  L=0                                                        ETABL.38    
               ENDIF                                                         ETABL.39    
               L=L-1                                                         ETABL.40    
            ENDDO                                                            ETABL.41    
            BLETA(II,JL)=BLE                                                 ETABL.42    
         ENDDO                                                               ETABL.43    
      ENDDO                                                                  ETABL.44    
C                                                                            ETABL.45    
      RETURN                                                                 ETABL.46    
      END                                                                    ETABL.47    
C     ***************************************************************        ETABL.48    
