      PROGRAM OFFLINE
C
C     Offline trajectory code for use with winds from ECMWF
C     GRIB files, Reading spectral model (BGCM5, RSGUP3 or RSGCM)
C     history files, or UKMO Unified Model output.
C
C     VERSION 3 customised for ECMWF data, including updates.
C
C     Author: John Methven, University of Reading  (20/3/97).
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)
C      PARAMETER(IGDLAP=1,IGCP=IGC)
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)
C
C
C     Must ensure that NSTSAV >= NSTEPS.
C
      PARAMETER(NSTSAV=20)
      COMMON/PATH/YP(NSTSAV,3)
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      REAL YSTART(3)
      INTEGER ITYPE,IEND,NGAP,ISET,IPOS,NTIME,KTIME,ITP,ITEL,ITELP
C
      CALL INITAL
C
C     Read first history file record for the initial g.p. fields.
C
      IF (LSPECTRAL) THEN
         CALL READREC
      ELSE
         IF (LOROG) CALL READOROG
         CALL READGP
      ENDIF
C
C     Initialise particle positions.
C     Calculate initial attributes and pressure at particles' positions,
C     if required.
C
      KTIME=1
      CALL INIPOSN(0,1)
      IF ((NATTR.GT.0).OR.(LPOUT)) CALL SETATTR(0,1)
      DAY=DAY+THIST
      NGAP=NINT(TRELEASE/THIST)
      IEND=NINT(TINTEG/THIST)
C
C     Loop over intervals between model (history file) outputs.
C
      DO 990 NTIME=1,IEND
C
C     Put winds and surface pressure from time 'tplus' into arrays
C     for time 'tminus'.
C
         DO 20 I=1,IGDLA
            UM(I)=URHS(I)
            VM(I)=VRHS(I)
            SDM(I)=SDRHS(I)
 20      CONTINUE
         DO 30 J=1,JG
            DO 32 I=1,IGC
               PLGLAM(I,J)=PLGLA(I,J)
 32         CONTINUE
 30      CONTINUE
         IF (LOROG.OR.(ILEVTYPE.EQ.2)) THEN
            DO 40 I=1,IGDLA
               PSGLAM(I)=PSGLA(I)
 40         CONTINUE
         ENDIF
C
C     Copy attributes from time 'tplus' to scratch files for 'tminus'.
C
         IF (LEVERY) THEN
            DO 50 IATTR=1,NATTR
               ITYPE=IATTRTYP(IATTR)
               IF (ITYPE.GT.0) THEN
                  ICHAN1=NCGP(ITYPE)
                  ICHAN2=ICHAN1+MAXATTR
                  CALL COPYATTR(ICHAN1,ICHAN2)
               ENDIF
 50         CONTINUE
         ENDIF
C
C     Obtain winds from next part of history record for time 'tplus'.
C
         IF (LSPECTRAL) THEN
            CALL READREC
         ELSE
            CALL READGP
         ENDIF
C
C     Loop over release sets.
C
         DO 980 ISET=1,NSETS
            IPOS=(ISET-1)*NPSET
            ITP=KTIME+1-(ISET-1)*NINT(TRELEASE/THIST)
            IF (ITP.LE.1) ITP=ITP+NHISTS-1
            ITELP=(ITP-1)*NJUMP+1
            ITEL=ITELP-NJUMP
C
C     Loop over particles within set.
C
            DO 982 II=1,NPSET
               ILAB=II+IPOS
               IF (POSN(ITEL,ILAB,3).GT.0.0) THEN
C
C     Operate Runge-Kutta scheme on one particle from time 'tminus' to
C     time 'tplus' if the particle is switched on.
C
                  DO 100 I=1,3
                     YSTART(I)=POSN(ITEL,ILAB,I)
 100              CONTINUE
                  CALL RKDUMB(YSTART,4,DAY-THIST,DAY,NSTEPS,H1)
C
C     Ensure that particles' longitude coordinates are cyclic.
C     Store trajectory coordinates.
C
                  IF (.NOT.LEVERY) THEN
                     DO 108 I=1,3
                        YP(1,I)=YSTART(I)
 108                 CONTINUE
                  ENDIF
                  DO 110 IINTER=1,NJUMP
                     IF (YP(IINTER,1).LT.0.) THEN
                        YMOD=-YP(IINTER,1)
                        NCYCLE=INT(YMOD/PI2)
                        YP(IINTER,1)=-(YMOD-NCYCLE*PI2)+PI2
                     ELSE
                        NCYCLE=INT(YP(IINTER,1)/PI2)
                        YP(IINTER,1)=YP(IINTER,1)-NCYCLE*PI2
                     ENDIF
                     DO 120 I=1,3
                        POSN(ITEL+IINTER,ILAB,I)=YP(IINTER,I)
 120                 CONTINUE
 110              CONTINUE
               ENDIF
 982        CONTINUE
C
C     Find attributes along trajectories if required.
C
            IF ((NATTR.GT.0).OR.(LPOUT)) CALL SETATTR(IPOS,ITELP)
C
C     Write out "mature" trajectories to ECMWF format file.
C
            IF (ITP.EQ.NHISTS) THEN
               IF ((DAY-BEGDAY).GE.RECINT) THEN
                  CALL WROUT(IPOS,NPSET)
               ENDIF
C
C     Initialise next set of trajectories if time to complete them.
C
               IF (NTIME.LE.(IEND-NHISTS+1)) THEN
                  CALL INIPOSN(IPOS,1)
                  IF ((NATTR.GT.0).OR.(LPOUT)) CALL SETATTR(IPOS,1)
               ELSE
C
C     Switch off particles in set if insufficient time to finish.
C
                  IF (NTIME.LT.IEND) THEN
                     DO 200 I=1,IPTS
                        DO 210 II=1,NPSET
                           POSN(I,IPOS+II,3)=0.
 210                    CONTINUE
 200                 CONTINUE
                  ENDIF
               ENDIF
            ENDIF
 980     CONTINUE
C
C     End of loop over history file intervals.
C
         KTIME=KTIME+1
         IF (KTIME.EQ.NHISTS) KTIME=1
         DAY=DAY+THIST
 990  CONTINUE
C
C     Write all trajectory data to a ".bin" file.
C
C     Removed call to binary output WRBIN.
C
      STOP
      END
C     ******************************************************************
      SUBROUTINE WROUT(IPOS,NPLEN)
C
C     Writes trajectory data for "mature" set to a file.
C     Can output pressure as the vertical coordinate.
C
C     IPOS = marker for start of "mature" set.
C     NPLEN = number of particles to output.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      COMMON/CLUSTERS/NCLUSTERS,IPOSN(MAXCLUS)
     :,IPOINTER(MAXCLUS)
     :,XCLUSTER(MAXCLUS),YCLUSTER(MAXCLUS),ZCLUSTER(MAXCLUS)
     :,XSPACE(MAXCLUS),YSPACE(MAXCLUS),ZSPACE(MAXCLUS)
     :,NXACR(MAXCLUS),NYACR(MAXCLUS),PHILIM,INISURF
C
      REAL POINTS(NFPPAR),AH
      INTEGER ISTEP,NCDATE,IPOS,NPLEN,ILAB,ITIME
      INTEGER NDIGDAT
C
 1000 FORMAT(I5,X,F7.2,(10E13.5))
C
C     Change the units of the coordinates to conform with the
C     standard. (T:days, long,lat:degrees, levels:1000.*ALEV)
C
C     LPOUT switches from output in eta coordinate to output
C     in pressure coordinate.
C
      DAY=DAY-RECINT
      IF (IUVFORMAT.EQ.2) THEN
         CALL MAKEUM(FSTEMO,IOFFOUT,INPFNAME,NCDATE)
      ELSE
         CALL MAKENAME(FSTEMO,IOFFOUT,INPFNAME,NCDATE,LGPQ)
      ENDIF
      DAY=DAY+RECINT
      NDIGDAT=7
      IF (NCDATE.GT.99999999) NDIGDAT=9
      OPEN(NCEC,FILE=INPFNAME(1:IOFFOUT+NDIGDAT),FORM='FORMATTED')
C
      IF (NCDATE.GT.IDATADATE) THEN
         LFORECAST=.TRUE.
      ELSE
         LFORECAST=.FALSE.
      ENDIF
      WRITE(NCEC,'(A25,I10)') ' TRAJECTORY BASE TIME IS ',NCDATE
      WRITE(NCEC,'(A19,I10)') ' DATA BASE TIME IS ',IDATADATE
      NHOURS=NINT(24.*THIST)
      WRITE(NCEC,'(A18,I4,A20,I4,A10)') ' DATA INTERVAL IS '
     :     ,NHOURS,' HOURS AND CONTAINS ',NSTEPS,' TIMESTEPS'
      WRITE(NCEC,'(A33,I8)')
     :     ' TOTAL NUMBER OF TRAJECTORIES IS ',NPLEN
      WRITE(NCEC,'(A25,I4)')
     :     ' NUMBER OF ATTRIBUTES IS ',NATTR
      WRITE(NCEC,'(A)') ' ATTRIBUTE TYPES = '
      WRITE(NCEC,'(20I4)') IATTRTYP(1:NATTR)
      WRITE(NCEC,'(A,I4)') ' NUMBER OF CLUSTERS IS ',NCLUSTERS
      WRITE(NCEC,'(A)') ' CLUSTER POINTERS = '
      WRITE(NCEC,'(10I7)') IPOINTER(1:NCLUSTERS)
      WRITE(NCEC,'(A)') ' 3D TRAJECTORY ? (T OR F): T'
      WRITE(NCEC,'(A,L1)') ' FORECAST DATA ? (T OR F): ',LFORECAST
      WRITE(NCEC,'(A,L1)') ' FORWARD TRAJECTORY ? (T OR F): ',LFORW
C
      DO 10 IP=1,NPLEN
         ILAB=IPOS+IP
         WRITE(NCEC,'(/,A19,I4,A11,I4,A10)') ' TRAJECTORY NUMBER '
     :        ,IP,' COMPRISES ',(IPTS-1)/NSKIP,' INTERVALS'
         WRITE(NCEC,'(/,A)')
     :' STEP   HOURS  LAT          LON          P (MB)      ATTRIBUTES'
         DO 20 ITIME=1,IPTS,NSKIP
            POINTS(1)=POSN(ITIME,ILAB,2)*180./PI
            POINTS(2)=POSN(ITIME,ILAB,1)*180./PI
            IF (LPOUT) THEN
               POINTS(3)=VPOSN(ITIME,ILAB)*1000.
            ELSE
               POINTS(3)=POSN(ITIME,ILAB,3)*1000.
            ENDIF
            IF (NATTR.GT.0) THEN
               DO 30 IATTR=1,NATTR
                  POINTS(3+IATTR)=POSN(ITIME,ILAB,3+IATTR)
 30            CONTINUE
            ENDIF
            ISTEP=(ITIME-1)*NSTEPS/NJUMP
            AH=(ITIME-1)*THIST*24./FLOAT(NJUMP)
            IF (.NOT.LFORW) AH=-AH
            WRITE(NCEC,1000) ISTEP,AH,(POINTS(I),I=1,NFPPAR)
 20      CONTINUE
 10   CONTINUE
C
      CLOSE(NCEC)
C
      RETURN
      END
C     ****************************************************************
      SUBROUTINE WRBIN
C
C     Writes trajectory data held in array POSN to a file NCBIN.
C     Can output pressure as the vertical coordinate.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      COMMON/CLUSTERS/NCLUSTERS,IPOSN(MAXCLUS)
     :,IPOINTER(MAXCLUS)
     :,XCLUSTER(MAXCLUS),YCLUSTER(MAXCLUS),ZCLUSTER(MAXCLUS)
     :,XSPACE(MAXCLUS),YSPACE(MAXCLUS),ZSPACE(MAXCLUS)
     :,NXACR(MAXCLUS),NYACR(MAXCLUS),PHILIM,INISURF
C
      INTEGER KFORW
C
C     Change the units of the coordinates to conform with the
C     standard. (T:days, long,lat:degrees, levels:1000.*ALEV)
C
C     LPOUT switches from output in eta coordinate to output
C     in pressure coordinate.
C
      IF (LPOUT) THEN
         DO 10 ILAB=1,NPART
            DO 20 NTIME=1,IPTS
               POSN(NTIME,ILAB,1)=POSN(NTIME,ILAB,1)*180./PI
               POSN(NTIME,ILAB,2)=POSN(NTIME,ILAB,2)*180./PI
               POSN(NTIME,ILAB,3)=VPOSN(NTIME,ILAB)*1000.
 20         CONTINUE
 10      CONTINUE
      ELSE
         DO 110 ILAB=1,NPART
            DO 120 NTIME=1,IPTS
               POSN(NTIME,ILAB,1)=POSN(NTIME,ILAB,1)*180./PI
               POSN(NTIME,ILAB,2)=POSN(NTIME,ILAB,2)*180./PI
               POSN(NTIME,ILAB,3)=POSN(NTIME,ILAB,3)*1000.
 120        CONTINUE
 110     CONTINUE
      ENDIF
C
C     Write the output .bin file.
C
      IF (LFORW) THEN
         KFORW=1
      ELSE
         KFORW=0
      ENDIF
      WRITE(NCBIN,'(5I8)') NPART,NCLUSTERS,IPTS,NATTR,KFORW
      WRITE(NCBIN,'(2E13.5)') BEGDAY,THIST
      WRITE(NCBIN,'(5E13.5)') POSN
C
      RETURN
      END
C     ****************************************************************
      SUBROUTINE INITAL
C
C     Initialise program.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
C
C     Must ensure that NSTSAV >= NSTEPS.
C
      PARAMETER(NSTSAV=20)
      COMMON/PATH/YP(NSTSAV,3)
C
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)
C      PARAMETER(IGDLAP=1,IGCP=IGC)
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      COMMON/CLUSTERS/NCLUSTERS,IPOSN(MAXCLUS)
     :,IPOINTER(MAXCLUS)
     :,XCLUSTER(MAXCLUS),YCLUSTER(MAXCLUS),ZCLUSTER(MAXCLUS)
     :,XSPACE(MAXCLUS),YSPACE(MAXCLUS),ZSPACE(MAXCLUS)
     :,NXACR(MAXCLUS),NYACR(MAXCLUS),PHILIM,INISURF
C
C
C     Set channel numbers.
C
      DATA
     : LOUTP/6/,INPUT/20/,INPUT2/21/,NCBIN/2/,NCEC/14/,NCINTRAJ/12/
C
C     Default values for namelist INPNAME.
C
      DATA
     : BEGDAY,THIST,TRELEASE,TINTEG,IUVFORMAT/0.,0.25,0.25,1.,0/
     :,LMULTI/.FALSE./,LSPECTRAL/.TRUE./,ILEVTYPE/0/,IWORDSIZE/8/
     :,AKAP,GA,RDGAS,RADEA,WW,P0/.286,9.81,287.,6.371E6,7.292E-5,1.E5/
     :,LTRACSWITCH/.FALSE./
     :,IATTRTYP/MAXATTR*0/,NCHI/1,2/,LPOUT/.FALSE./
     :,NSTEPS/10/,LFORW/.TRUE./,LEVERY/.FALSE./,NSKIP/1/
      NAMELIST/INPNAME/BEGDAY,THIST,TRELEASE,TINTEG,IUVFORMAT
     :,LMULTI,LSPECTRAL,ILEVTYPE,IWORDSIZE
     :,AKAP,GA,RADEA,WW,P0,RDGAS
     :,LTRACSWITCH,KOLOUR
     :,IATTRTYP,NCHI,LPOUT,LEVERY,NSKIP
     :,NSTEPS,LFORW
C
C
C     Default values for namelist CLUSNAME.
C
      DATA
     : NCLUSTERS/1/,IPOSN/MAXCLUS*0/
     :,XCLUSTER/MAXCLUS*30./,YCLUSTER/MAXCLUS*45./
     :,ZCLUSTER/MAXCLUS*0.5/,XSPACE/MAXCLUS*1./,YSPACE/MAXCLUS*1./
     :,ZSPACE/MAXCLUS*0.05/,NXACR/MAXCLUS*1/,NYACR/MAXCLUS*1/
     :,PHILIM/0./,INISURF/0/
     :,IPOINTER/MAXCLUS*0/
      NAMELIST/CLUSNAME/NCLUSTERS,IPOSN,XCLUSTER,YCLUSTER,ZCLUSTER
     :,XSPACE,YSPACE,ZSPACE,NXACR,NYACR,PHILIM,INISURF
C
C
C     Default values for namelist DATENAME.
C
      DATA
     : ISYY/96/,ISMM/01/,ISDD/01/,ISHH/00/
     :,NRECPFILE/1/,IOFFOUT/5/,FSTEMO/'ec2d'/
      NAMELIST/DATENAME/ISYY,ISMM,ISDD,ISHH,NRECPFILE,IOFFOUT,FSTEMO
C
C
C     Default values for namelist GRIBNAME.
C
      DATA
     : FSTEM/'siua'/,FSTEM2/'giua'/
     :,IOFFSET/5/,LERA/.FALSE./,IDATADATE/96010100/
      NAMELIST/GRIBNAME/IOFFSET,FSTEM,FSTEM2,LERA,IDATADATE
C
C
C     Default values for namelist RSNAME.
C
      DATA
     : RNTAPE/1./,TSPD/48./,LDRY/.TRUE./,LT3D/.TRUE./
      NAMELIST/RSNAME/RNTAPE,TSPD,LDRY,LT3D
C     ********************************************************************
C
C     Read namelists.
C
      WRITE(LOUTP,*) 'Reading namelist INPNAME.'
      READ(5,INPNAME)
      WRITE(LOUTP,*) 'Reading namelist CLUSNAME.'
      READ(5,CLUSNAME)
      WRITE(LOUTP,*) 'Reading namelist DATENAME.'
      READ(5,DATENAME)
      WRITE(LOUTP,*) 'Reading namelist GRIBNAME.'
      READ(5,GRIBNAME)
      WRITE(LOUTP,*) 'Reading namelist RSNAME.'
      READ(5,RSNAME)
C
C     Checks on compatibility of parameters and namelist controls.
C     Output interpretation of namelist controls to channel LOUTP.
C
      IF (IWORDSIZE.EQ.8) THEN
         WRITE(LOUTP,*)
     :        'IWORDSIZE set for 64-bit computer (e.g. CRAY).'
      ELSE
         IF (IWORDSIZE.EQ.4) THEN
            WRITE(LOUTP,*)
     :        'IWORDSIZE set for 32-bit computer (e.g. workstation).'
         ELSE
            WRITE(LOUTP,*)
     :        '****WARNING**** unexpected value for IWORDSIZE.'
         ENDIF
      ENDIF
      IF (IUVFORMAT.EQ.0) THEN
         WRITE(LOUTP,*) 'Expecting ECMWF wind data.'
      ELSE IF (IUVFORMAT.EQ.1) THEN
         WRITE(LOUTP,*) 'Expecting Reading spectral model history.'
      ELSE IF (IUVFORMAT.EQ.2) THEN
         WRITE(LOUTP,*) 'Expecting UKMO Unified Model data.'
      ENDIF
      IF ((IUVFORMAT.EQ.1).AND.(.NOT.LSPECTRAL)) THEN
         WRITE(LOUTP,*) 'MUST SELECT LSPECTRAL=.TRUE. WHEN USING
     :        READING SPECTRAL DATA.'
         LSPECTRAL=.TRUE.
      ENDIF
      IF (LSPECTRAL.AND.(IUVFORMAT.GT.1)) THEN
         WRITE(LOUTP,*) 'MUST SELECT LSPECTRAL=.FALSE. WHEN NOT USING
     :         ECMWF OR READING SPECTRAL DATA.'
         LSPECTRAL=.FALSE.
      ENDIF
C
C     Determine gridtype and vertical coordinate.
C
C     Vertical coordinate in which particles are advected must
C     be compatible with supplied vertical velocity.
C
      IF (LSPECTRAL) THEN
         IGRIDTYPE=0
         WRITE(LOUTP,*) 'Using GAUSSIAN grid.'
         LEVZT1=.TRUE.
         WRITE(LOUTP,*) 'Assuming levels ordered from top to ground.'
         ILEVTYPE=0
         WRITE(LOUTP,*) 'ASSUME SPECTRAL DATA TO BE ON ETA LEVELS.'
         LOROG=.FALSE.
      ELSE
         IGRIDTYPE=1
         WRITE(LOUTP,*) 'Assuming data on a REGULAR LAT-LON grid.'
         IF (IUVFORMAT.EQ.0) THEN
            LEVZT1=.FALSE.
            WRITE(LOUTP,*)
     :           'Assuming levels ordered from ground to top.'
            ILEVTYPE=1
            WRITE(LOUTP,*)
     :           'Assuming ECMWF gridded data is on PRESSURE levels.'
            LOROG=.TRUE.
            WRITE(LOUTP,*)
     :           'Must supply OROGRAPHY in file FSTEM2.'
         ELSE
            LEVZT1=.TRUE.
            WRITE(LOUTP,*)
     :           'Levels re-ordered from top to ground when read in.'
            LOROG=.FALSE.
            WRITE(LOUTP,*) 'Must supply surface pressure field.'
         ENDIF
         IF (ILEVTYPE.EQ.0) THEN
            WRITE(LOUTP,*) 'Reading data on eta-levels.'
         ELSE
            IF (ILEVTYPE.EQ.1) THEN
               WRITE(LOUTP,*) 'Reading data on pressure levels.'
            ENDIF
            IF (ILEVTYPE.EQ.2) THEN
               WRITE(LOUTP,*) '****WARNING****'
               WRITE(LOUTP,*) 'ILEVTYPE=2 currently not supported.'
            ENDIF
            IF (LPOUT) THEN
               WRITE(LOUTP,*) 'SETTING LPOUT=.FALSE. SINCE PRESSURE IS
     :              OUTPUT AS THE DEFAULT WHEN ILEVTYPE IS NOT ZERO.'
               LPOUT=.FALSE.
            ENDIF
         ENDIF
      ENDIF
C
C     Check for backward trajectories.
C
      WRITE(LOUTP,*)' '
      IF (LFORW) THEN
         WRITE(LOUTP,*)'FORWARD TRAJECTORIES.'
      ELSE
         WRITE(LOUTP,*)'BACK TRAJECTORIES.'
      ENDIF
      IF ((.NOT.LFORW).AND.(NRECPFILE.GT.1).AND.(IUVFORMAT.NE.2)) THEN
         WRITE(LOUTP,*) '***WARNING*** The wind records must be
     :   ordered in reverse for back trajectory calculations.'
      ENDIF
      NCDATE=ISYY*1000000+ISMM*10000+ISDD*100+ISHH
      IF (NCDATE.GT.IDATADATE) THEN
         WRITE(LOUTP,*)'Using wind data forecast on ',IDATADATE
      ELSE
         WRITE(LOUTP,*)'Using archived wind data.'
      ENDIF
C
C     Check on intermediate trajectory saving operation.
C
      IF (NSTSAV.LT.NSTEPS) THEN
         WRITE(LOUTP,*)'NSTSAV must be >= NSTEPS.'
         WRITE(LOUTP,*)'NSTSAV = ',NSTSAV,'    NSTEPS = ',NSTEPS
         STOP                   90
      ENDIF
      IF(LEVERY) THEN
         WRITE(LOUTP,*)'Trajectories recorded after every time-step.'
         REM=FLOAT(IPTS-1)/FLOAT(NSTEPS)-(IPTS-1)/NSTEPS
         IF (REM.GT.1.E-7) THEN
            WRITE(LOUTP,*)
     :           'IPTS-1 must be an integer multiple of NSTEPS.'
            WRITE(LOUTP,*)'NSTEPS = ',NSTEPS,'    IPTS = ',IPTS
            STOP                   91
         ENDIF
         WRITE(LOUTP,*)'Trajectories output every '
     :        ,NSKIP*THIST/NSTEPS,' days.'
         NHISTS=(IPTS-1)/NSTEPS+1
         NJUMP=NSTEPS
      ELSE
         WRITE(LOUTP,*)'Trajectories recorded at time interval THIST.'
         WRITE(LOUTP,*)'Trajectories output every '
     :        ,NSKIP*THIST,' days.'
         NHISTS=IPTS
         NJUMP=1
      ENDIF
C
C     Check on parallel trajectory set operation.
C
      RECINT=(NHISTS-1)*THIST
      IF (LMULTI) THEN
         WRITE(LOUTP,*)
     :    'Parallel trajectory sets run with staggered release times.'
         REM=TRELEASE/THIST-INT(TRELEASE/THIST)
         IF ((REM.NE.0).OR.(TRELEASE.EQ.0)) THEN
            WRITE(LOUTP,*)
     :           'TRELEASE should be an integer multiple of THIST.'
            STOP                100
         ENDIF
         REM=RECINT/TRELEASE-INT(RECINT/TRELEASE)
         IF ((REM.NE.0).OR.(RECINT.EQ.0)) THEN
            WRITE(LOUTP,*)
     :           'RECINT should be an integer multiple of TRELEASE.'
            STOP                101
         ENDIF
         REM=TINTEG/THIST-INT(TINTEG/THIST)
         IF ((REM.NE.0).OR.(TINTEG.LT.(RECINT+TRELEASE))) THEN
            WRITE(LOUTP,*)
     :       'THIST=',THIST,'  TINTEG=',TINTEG,'  RECINT=',RECINT
            WRITE(LOUTP,*)
     :       'TINTEG should be an integer multiple of THIST.'
            WRITE(LOUTP,*)
     :       'TINTEG should also be >= RECINT+TRELEASE.'
            STOP                102
         ENDIF
         NSETS=NINT(RECINT/TRELEASE)
         WRITE(LOUTP,*) NSETS,' sets of trajectories at any one time.'
         RNPART=FLOAT(NPART)
         REM=RNPART*TRELEASE/RECINT-NPART/NSETS
         IF (REM.GT.0.00001) THEN
            WRITE(LOUTP,*) 'NPART should be a multiple of NSETS.'
            WRITE(LOUTP,*) 'REM = ',REM
            STOP                103
         ENDIF
         NPSET=NPART/NSETS
         WRITE(LOUTP,*) NPSET,' trajectories per set.'
      ELSE
         WRITE(LOUTP,*) 'All trajectories released at the same time.'
         TINTEG=RECINT
         TRELEASE=RECINT
         NSETS=1
         NPSET=NPART
      ENDIF
C
C     Checks on initial positions.
C
      NPTEST=0
      DO 10 ICL=1,NCLUSTERS
         WRITE(LOUTP,*) 'CLUSTER ',ICL
         IF (IPOSN(ICL).EQ.0) THEN
            WRITE(LOUTP,*) 'No initial arrangement for cluster.'
            STOP                   2
         ENDIF
         IF (IPOSN(ICL).EQ.1) THEN
            NIDEAL=MG*JG*NCLUSTERS*NHEM
            WRITE(LOUTP,*) NIDEAL
     :           ,' particles to start on every gridpoint.'
            NPTEST=NPTEST+NIDEAL
         ENDIF
         IF (IPOSN(ICL).EQ.2) THEN
            NIDEAL=((MG+1)/2)*((JG+1)/2)*NCLUSTERS*NHEM
            WRITE(LOUTP,*) NIDEAL
     :           ,' particles to start on every other gridpoint.'
            NPTEST=NPTEST+NIDEAL
         ENDIF
         IF (IPOSN(ICL).EQ.3) THEN
            NIDEAL=NXACR(ICL)*NYACR(ICL)
            WRITE(LOUTP,*) NIDEAL
     :           ,' particles in regular lon-lat rectangle.'
            NPTEST=NPTEST+NIDEAL
         ENDIF
         IF (IPOSN(ICL).EQ.4) THEN
            NIDEAL=NXACR(ICL)*NYACR(ICL)
            WRITE(LOUTP,*) NIDEAL
     :           ,' particles in regular lon-sin(lat) rectangle.'
            NPTEST=NPTEST+NIDEAL
         ENDIF
         IF (IPOSN(ICL).EQ.5) THEN
            NIDEAL=7
            WRITE(LOUTP,*) NIDEAL
     :           ,' particles in 3-D ball.'
            NPTEST=NPTEST+NIDEAL
            IF (INISURF.GT.0) THEN
               WRITE(LOUTP,*) 'SETTING INISURF=0 FOR BALL CLUSTERS.'
               INISURF=0
            ENDIF
         ENDIF
         IF (IPOSN(ICL).EQ.6) THEN
            NIDEAL=NPSET/NCLUSTERS
            WRITE(LOUTP,*) NIDEAL
     :           ,' particles homogeneously spread on stereographic.'
            NPTEST=NPTEST+NIDEAL
            IF (MOCT.LT.2) THEN
               WRITE(LOUTP,*) 'MOCT > 1 for this arrangement.'
               STOP          3
            ENDIF
         ENDIF
         IF (IPOSN(ICL).EQ.7) THEN
            NIDEAL=NPSET
            WRITE(LOUTP,*) NIDEAL
     :           ,' particles restarted from an old record.'
            NPTEST=NPTEST+NIDEAL
            IF (NCLUSTERS.GT.1) THEN
               WRITE(LOUTP,*) 'NCLUSTERS=1 for this arrangement.'
               STOP          4
            ENDIF
         ENDIF
 10   CONTINUE
      IF (NPTEST.NE.NPSET) THEN
         WRITE(LOUTP,*) 'Number of particles per set is not equal to'
         WRITE(LOUTP,*) 'the sum of those in each cluster.'
         WRITE(LOUTP,*) 'SUM = ',NPTEST,'      NPSET = ',NPSET
         STOP                5
      ENDIF
      IF (INISURF.EQ.0) THEN
         WRITE(LOUTP,*) 'Placing particles on model levels.'
      ENDIF
      IF (INISURF.EQ.1) THEN
         WRITE(LOUTP,*) 'Placing particles on pressure surfaces.'
         IF (ILEVTYPE.NE.0) THEN
C
C     Pressure is used as the particles' vertical coordinate
C     (rather than eta).
C
            INISURF=0
         ENDIF
      ENDIF
      IF (INISURF.EQ.2) THEN
         WRITE(LOUTP,*) 'Placing particles on theta surfaces.'
         WRITE(LOUTP,*) '****WARNING**** Must supply temperature!'
         LTATTR=.TRUE.
      ELSE
         LTATTR=.FALSE.
      ENDIF
C
C     Check on the existance of moisture and tracers in the
C     history record, if required for assigning values to
C     particle attributes.
C
      LQATTR=.FALSE.
      LPVATTR=.FALSE.
      IF (NATTR.GT.0) THEN
         IF (LTRACSWITCH.AND.(IUVFORMAT.EQ.0)) THEN
            WRITE(LOUTP,*) 'No tracers in ECMWF history files so
     :      should use LTRACSWITCH=.FALSE. .'
            STOP                  7
         ENDIF
         DO 20 IATTR=1,NATTR
            IF(IATTRTYP(IATTR).EQ.0) THEN
               WRITE(LOUTP,*)'Attributing surface pressure.'
            ENDIF
            IF(IATTRTYP(IATTR).EQ.1) THEN
               LTATTR=.TRUE.
               WRITE(LOUTP,*)'Attributing temperature.'
            ENDIF
            IF(IATTRTYP(IATTR).EQ.2) THEN
               LTATTR=.TRUE.
               WRITE(LOUTP,*)'Attributing potential temperature.'
            ENDIF
            IF (IATTRTYP(IATTR).EQ.3) THEN
               LPVATTR=.TRUE.
               WRITE(LOUTP,*)'Attributing Ertel PV.'
               IF(LSPECTRAL) THEN
                  LTATTR=.TRUE.
               ELSE
                  WRITE(LOUTP,*)'****WARNING****'
                  WRITE(LOUTP,*)
     :              'PV must be provided as a field in data record.'
               ENDIF
            ENDIF
            IF(IATTRTYP(IATTR).EQ.4) THEN
               LQATTR=.TRUE.
               WRITE(LOUTP,*)'Attributing moisture variable.'
               IF ((IUVFORMAT.EQ.1).AND.LDRY) THEN
                  WRITE(LOUTP,*)'No moisture in history file so cannot
     :            assign a specific humidity as an attribute.'
                  STOP               8
               ENDIF
            ENDIF
            IF(IATTRTYP(IATTR).EQ.5.AND.(.NOT.LTRACSWITCH)) THEN
               WRITE(LOUTP,*) 'No tracers in history file so cannot
     :         assign a tracer as an attribute.'
               STOP               9
            ENDIF
            IF(IATTRTYP(IATTR).EQ.6.AND.(NTRAC.LE.1)) THEN
               WRITE(LOUTP,*) 'One tracer in history file so cannot
     :         assign a 2 tracers as attributes.'
               STOP               10
            ENDIF
 20      CONTINUE
      ENDIF
      WRITE(LOUTP,*) ' '
C
C     Dimensionalising factors and fundamental constants.
C
      CV=RADEA*WW
      CT=CV*CV/RDGAS
      CQ=1000.
      CERT=1.E6*CT*WW*GA/P0
      IF (LTRACSWITCH) THEN
         DO 30 I=1,NTRAC
            CTRA(I)=1.
            IF (KOLOUR(I).EQ.1) THEN
               CTRA(I)=CT
            ENDIF
            IF (KOLOUR(I).EQ.2) THEN
               CTRA(I)=CERT
            ENDIF
 30      CONTINUE
      ENDIF
C
      DAY=BEGDAY
C
C     Set channels for attribute scratch files.
C
      DO 40 I=1,MAXATTR
         NCGP(I)=39+I
 40   CONTINUE
C
C     First guess for grid point of first particle for hunt search.
C
      JSAV=JGG/2
      LSAV=NL/2
      LHSAV=NLM/2
C
C     Put the longitudinal grid spacing as separate variable.
C     Already done for vert. and latitudinal spacing.
C
      DLAM=PI2DM/MG
C
C     Call set up routines which are specific to the format
C     of the wind (and other attribute) data.
C
      IF (IUVFORMAT.EQ.0) CALL INIGS
      IF (IUVFORMAT.EQ.1) CALL INIRS
      IF (IUVFORMAT.EQ.2) CALL INIUM
      IF (IUVFORMAT.EQ.3) CALL INIARB
C
      IF (IUVFORMAT.NE.2) THEN
         ZUBZX=-DLAM
         ZTBZX=ZUBZX
         DO 100 J=1,JGG
            ALATT(J)=ALAT(J)
 100     CONTINUE
      ENDIF
C
      DO 110 IATTR=1,MAXATTR
         LUGRID(IATTR)=.FALSE.
         IF ((IATTRTYP(IATTR).EQ.4).AND.(ILEVTYPE.EQ.1)
     :       .AND.(IUVFORMAT.EQ.2)) THEN
            LUGRID(IATTR)=.TRUE.
         ENDIF
 110  CONTINUE
C
      IF ((IUVFORMAT.LE.1).AND.(ILEVTYPE.EQ.0)) THEN
C
C     RGG matrix for vertical derivatives (used by DLSGCR):
C     d()/dln(sigma) = (sigma)d()/d(sigma).
C
         IL=0
         DO 120 L=1,NL
            RGVAL=SIGMA(L)*0.5/DSIGMA(L)
            DO 122 M=1,NL
               IL=IL+1
               RGG(IL)=0.
               IF (M.EQ.L-1) RGG(IL)=-RGVAL
               IF (M.EQ.L+1) RGG(IL)=RGVAL
 122        CONTINUE
 120     CONTINUE
         DA=SIGMA(1)
         DB=SIGMA(2)-DA
         DC=SIGMA(3)-SIGMA(2)
         DD=DC+DB
         RGG(1)=-DA*(DD+DB)/(DB*DD)
         RGG(2)=DA*DD/(DB*DC)
         RGG(3)=-DA*DB/(DC*DD)
         DA=SIGMA(NL)
         DD=SIGMA(NL-1)
         DB=DA-DD
         DC=DD-SIGMA(NL-2)
         DD=DC+DB
         RGG(NL2)=DA*(DD+DB)/(DB*DD)
         RGG(NL2-1)=-DA*DD/(DB*DC)
         RGG(NL2-2)=DA*DB/(DC*DD)
      ENDIF
C
C     Set the stepsize for the non-adaptive R-K scheme.
C
      H1=THIST/REAL(NSTEPS)
C
C     Set grid point wind fields to zero.
C
C
      DO 140 I=1,IGD
         UG(I)=0.0
         VG(I)=0.0
         ZG(I)=0.0
         DG(I)=0.0
         TG(I)=0.0
         TXG(I)=0.0
         TYG(I)=0.0
         SDOTG(I)=0.0
         THG(I)=0.0
         QG(I)=0.0
         EPVG(I)=0.0
 140   CONTINUE
      DO 142 I=1,IGC
         PLG(I)=0.0
         PJG(I)=0.0
         PMG(I)=0.0
 142   CONTINUE
      DO 150 I=1,IGDLA
         URHS(I)=0.0
         VRHS(I)=0.0
         SDRHS(I)=0.0
         THGLA(I)=0.0
 150  CONTINUE
      DO 160 J=1,JG
         DO 170 I=1,IGC
            PLGLA(I,J)=0.0
 170     CONTINUE
 160  CONTINUE
      IF(.NOT.LSPECTRAL) THEN
         DO 180 I=1,IGDLA
            PSGLA(I)=0.0
 180     CONTINUE
      ENDIF
C
C     Set initial positions to zero.
C
      DO 200 I=1,NFPPAR
         DO 205 ILAB=1,NPART
            DO 210 ITIME=1,IPTS
               POSN(ITIME,ILAB,I)=0.0
 210        CONTINUE
 205     CONTINUE
 200  CONTINUE
      IF (LPOUT) THEN
         DO 220 ILAB=1,NPART
            DO 225 ITIME=1,IPTS
               VPOSN(ITIME,ILAB)=0.0
 225        CONTINUE
 220     CONTINUE
      ENDIF
C
      RETURN
      END
C     ***************************************************************
      SUBROUTINE INIPOSN(IPOS,NTIME)
C
C     Initialise particle positions.
C
C     IPOS = marker for start of "mature" set.
C     NTIME = denotes current time label for POSN.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      COMMON/CLUSTERS/NCLUSTERS,IPOSN(MAXCLUS)
     :,IPOINTER(MAXCLUS)
     :,XCLUSTER(MAXCLUS),YCLUSTER(MAXCLUS),ZCLUSTER(MAXCLUS)
     :,XSPACE(MAXCLUS),YSPACE(MAXCLUS),ZSPACE(MAXCLUS)
     :,NXACR(MAXCLUS),NYACR(MAXCLUS),PHILIM,INISURF
C
      PARAMETER(IPTSB=29,NATTRB=0)
      REAL POSNB(IPTSB,NPART,3+NATTRB)
      REAL XCL,YCL,XSP,YSP,YTEMP,PHIL
      INTEGER NCL1,M,J,IPOS,NTIME,ILAB,ICL
C
      M=0
      J=0
      ILAB=IPOS
      DO 10 ICL=1,NCLUSTERS
         IF (IPOS.EQ.0) IPOINTER(ICL)=ILAB+1
         IF (IPOSN(ICL).EQ.1) THEN
C
C     Initialise a particle on every g.p. in the horizontal
C     and on levels given by ZCLUSTER. (NCL1=MG*JG*NCLUSTERS*NHEM)
C
            DO 110 J=1,JGG
               DO 120 M=1,MG
                  ILAB=ILAB+1
                  POSN(NTIME,ILAB,1)=ZTBZX+M*DLAM
                  POSN(NTIME,ILAB,2)=ALATT(J)
                  IF(INISURF.GT.0) THEN
                     CALL ONTHETA(ILAB,ICL,M,J,NTIME)
                  ELSE
                     POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)
                  ENDIF
 120           CONTINUE
 110        CONTINUE
            GOTO 990
         ENDIF
         IF (IPOSN(ICL).EQ.2) THEN
C
C     Initialise a particle on every other g.p. in the horizontal
C     and on levels given by ZCLUSTER.
C     ( NCL1=(MG+1)/2*(JG+1)/2*NCLUSTERS*NHEM ; integer division )
C
            DO 210 J=1,JG,2
               DO 220 M=1,MG,2
                  ILAB=ILAB+1
                  POSN(NTIME,ILAB,1)=ZTBZX+M*DLAM
                  POSN(NTIME,ILAB,2)=ALATT(J)
                  IF(INISURF.GT.0) THEN
                     CALL ONTHETA(ILAB,ICL,M,J,NTIME)
                  ELSE
                     POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)
                  ENDIF
 220           CONTINUE
 210        CONTINUE
C
C     Set particles symmetrically about equator.
C
            IF (NHEM.EQ.2) THEN
               DO 240 J=JGG,JG+1,-2
                  DO 250 M=1,MG,2
                     ILAB=ILAB+1
                     POSN(NTIME,ILAB,1)=ZTBZX+M*DLAM
                     POSN(NTIME,ILAB,2)=ALATT(J)
                     IF(INISURF.GT.0) THEN
                        CALL ONTHETA(ILAB,ICL,M,J,NTIME)
                     ELSE
                        POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)
                     ENDIF
 250              CONTINUE
 240           CONTINUE
            ENDIF
            GOTO 990
         ENDIF
         IF (IPOSN(ICL).EQ.3) THEN
C
C     Rectangular clusters, each initialised on a single level.
C
C     Initialise a cluster with coordinates of north-west corner
C     given by XCLUSTER,YCLUSTER (in degrees) and ZCLUSTER (level).
C     The angular spacing between particles (in degrees) is given by
C     XSPACE and YSPACE, and the number of particles along
C     a parallel and a meridian is given by NXACR and NYACR.
C     All angles are converted to radians for the calculation.
C
C     Loop over the number of clusters.
C
            IF (XCLUSTER(ICL).LT.0.) THEN
               XCLUSTER(ICL)=360.+XCLUSTER(ICL)
            ENDIF
            XCL=XCLUSTER(ICL)*PI/180.
            YCL=YCLUSTER(ICL)*PI/180.
            XSP=XSPACE(ICL)*PI/180.
            YSP=YSPACE(ICL)*PI/180.
C
C     The origin of cluster is at the north-west corner.
C     Position points on a grid to the right with correct spacing.
C
            DO 310 ID=1,NYACR(ICL)
               DO 320 I=1,NXACR(ICL)
                  ILAB=ILAB+1
                  POSN(NTIME,ILAB,1)=XCL+(I-1)*XSP
                  POSN(NTIME,ILAB,2)=YCL-(ID-1)*YSP
                  IF(INISURF.GT.0) THEN
                     CALL ONTHETA(ILAB,ICL,M,J,NTIME)
                  ELSE
                     POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)
                  ENDIF
 320           CONTINUE
 310        CONTINUE
            GOTO 990
         ENDIF
         IF (IPOSN(ICL).EQ.4) THEN
C
C     Rectangular clusters, each initialised on a single level.
C
C     As for IPOSN(ICL)=3 except spacing is regular in sin(latitude)
C     and units for Y... are expected to lie between -1 and 1.
C
C     Loop over the number of clusters.
C
            IF (XCLUSTER(ICL).LT.0.) THEN
               XCLUSTER(ICL)=360.+XCLUSTER(ICL)
            ENDIF
            XCL=XCLUSTER(ICL)*PI/180.
            YCL=YCLUSTER(ICL)
            XSP=XSPACE(ICL)*PI/180.
            YSP=YSPACE(ICL)
C
C     The origin of cluster is at the north-west corner.
C     Position points on a grid to the right with correct spacing.
C
            DO 410 ID=1,NYACR(ICL)
               YTEMP=YCL-(ID-1)*YSP
               IF (ABS(YTEMP).GT.1.) THEN
                  WRITE(LOUTP,*)
     :               '*****WARNING sin(lat) is out of range = ',YTEMP
                  STOP
               ENDIF
               YTEMP=ASIN(YTEMP)
               DO 420 I=1,NXACR(ICL)
                  ILAB=ILAB+1
                  POSN(NTIME,ILAB,1)=XCL+(I-1)*XSP
                  POSN(NTIME,ILAB,2)=YTEMP
                  IF(INISURF.GT.0) THEN
                     CALL ONTHETA(ILAB,ICL,M,J,NTIME)
                  ELSE
                     POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)
                  ENDIF
 420           CONTINUE
 410        CONTINUE
            GOTO 990
         ENDIF
         IF (IPOSN(ICL).EQ.5) THEN
C
C     Ball clusters each containing 7 particles.
C
C     Initialise a cluster with coordinates of centre given by
C     XCLUSTER,YCLUSTER (in degrees) and ZCLUSTER (level).
C     The separation of particles in each cluster (in degrees)
C     is given by XSPACE and YSPACE.
C     All angles are converted to radians for the calculation.
C
C     Loop over the number of clusters.
C
            IF (XCLUSTER(ICL).LT.0.) THEN
               XCLUSTER(ICL)=360.+XCLUSTER(ICL)
            ENDIF
            XCL=XCLUSTER(ICL)*PI/180.
            YCL=YCLUSTER(ICL)*PI/180.
            XSP=XSPACE(ICL)*PI/180.
            YSP=YSPACE(ICL)*PI/180.
C
C     Intialise each ball of points around the central particle.
C
            DO 510 IBALL=1,7
               ILAB=ILAB+1
               XOFF=0.
               PHIOFF=0.
               SIGOFF=0.
               IF(IBALL.EQ.2) XOFF=-XSP
               IF(IBALL.EQ.3) XOFF=XSP
               IF(IBALL.EQ.4) PHIOFF=-YSP
               IF(IBALL.EQ.5) PHIOFF=YSP
               IF(IBALL.EQ.6) SIGOFF=-ZSPACE(ICL)
               IF(IBALL.EQ.7) SIGOFF=ZSPACE(ICL)
               POSN(NTIME,ILAB,1)=XCL+XOFF
               POSN(NTIME,ILAB,2)=YCL+PHIOFF
               POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)+SIGOFF
 510        CONTINUE
            GOTO 990
         ENDIF
         IF (IPOSN(ICL).EQ.6) THEN
C
C     Initialise the particles in an isotropic, homogeneous pattern
C     on a polar stereographic projection with MOCT-fold symmetry.
C
C     PHILIM = the Southern extent of the particles (in degrees).
C     NPSET must be a multiple of the number of clusters.
C
            ISTART=ILAB
            NCL1=NPSET/NCLUSTERS
            N=INT(SQRT(REAL(MOCT*NCL1)/PI))+1
            PHIL=PHILIM*PI/180.
            XLIM=COS(PHIL)/(1+SIN(PHIL))
            DX=XLIM/REAL(N)
C
C     Loop over the nodes along the x-axis of the projection.
C
            X=-DX/2.
            DO 610 I=1,N
               X=X+DX
               Y=DX/2.
 620           RLAM=ATAN(Y/X)
               PHI=PI/2.-2*ATAN(SQRT(X**2+Y**2))
C
C     Check to see if the (RLAM,PHI) point lies within the domain.
C     If it does the initialise its position and then increase y and
C     check the next point.
C     Otherwise turn the particle OFF by setting its sigma-coordinate
C     to zero and then move on to the next node on the x-axis.
C
               IF ((RLAM.GT.0).AND.(RLAM.LT.PI2DM)
     :              .AND.(PHI.GT.PHIL)) THEN
                  ILAB=ILAB+1
                  NDONE=ILAB-ISTART
                  IF (NDONE.GT.NCL1) GOTO 990
                  POSN(NTIME,ILAB,1)=RLAM
                  POSN(NTIME,ILAB,2)=PHI
                  IF(INISURF.GT.0) THEN
                     CALL ONTHETA(ILAB,ICL,M,J,NTIME)
                  ELSE
                     POSN(NTIME,ILAB,3)=ZCLUSTER(ICL)
                  ENDIF
                  Y=Y+DX
                  GOTO 620
               ENDIF
 610        CONTINUE
            GOTO 990
         ENDIF
         IF (IPOSN(ICL).EQ.7) THEN
C
C     Initialise positions from an existing '.bin' format traj file.
C     Convert degrees to radians for positions.
C     The input file must be from a run which used LPOUT=.FALSE. .
C
            READ(NCINTRAJ,'(5I8)') NPARTR,NCLR,IPTSR,NATTRR,KFORWR
            READ(NCINTRAJ,'(2E13.5)') BEGDAYR,THISTR
            READ(NCINTRAJ,'(5E13.5)') POSNB
            NSTART=NINT((BEGDAY-BEGDAYR)/THISTR) +1
            DO 700 I=1,NPSET
               ILAB=ILAB+1
               POSN(NTIME,ILAB,1)=POSNB(NSTART,ILAB,1)*PI/180.
               POSN(NTIME,ILAB,2)=POSNB(NSTART,ILAB,2)*PI/180.
               POSN(NTIME,ILAB,3)=POSNB(NSTART,ILAB,3)/1000.
 700        CONTINUE
            GOTO 990
         ENDIF
         WRITE(LOUTP,*) 'Position type ',IPOSN(ICL),
     :        ' is not supported.'
C
 990     CONTINUE
 10   CONTINUE
C
      RETURN
      END
C     *************************************************************
      SUBROUTINE ONTHETA(ILAB,ICL,MR,JR,NTIME)
C
C     To calculate the sigma-coordinate of a particle, label ILAB,
C     given its longitude, latitude and desired initial
C     pressure or potential temperature of its cluster.
C
C     INISURF=1 : Place on pressure surface (ZCLUSTER units: 10^5 Pa).
C     INISURF=2 : Place on theta surface (ZCLUSTER units: K).
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)
C      PARAMETER(IGDLAP=1,IGCP=IGC)
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      COMMON/CLUSTERS/NCLUSTERS,IPOSN(MAXCLUS)
     :,IPOINTER(MAXCLUS)
     :,XCLUSTER(MAXCLUS),YCLUSTER(MAXCLUS),ZCLUSTER(MAXCLUS)
     :,XSPACE(MAXCLUS),YSPACE(MAXCLUS),ZSPACE(MAXCLUS)
     :,NXACR(MAXCLUS),NYACR(MAXCLUS),PHILIM,INISURF
C
      PARAMETER (MAXIT=100)
      REAL Y(3),THETA(NL),ZPART(NL),PHOUT(NL+1),PSURF,BOUND
      REAL P,Q,OMP,OMQ,XA(4),YA(4),SIGOUT,THACC
      INTEGER ILAB,ICL,MR,JR,M,MP,J,JM,JHEM,JHEMM,L
C
C     If particles do not intially lie on g.p.'s in the horizontal
C     then interpolate the theta field to the particle's horizontal
C     position.
C
      IF (IPOSN(ICL).GE.3) THEN
C
C     Find the south-west vertex of the grid box surrounding
C     the particle.
C

         Y(1)=POSN(NTIME,ILAB,1)
         Y(2)=POSN(NTIME,ILAB,2)
         Y(3)=0.
         CALL FINDSW(Y,ZTBZX,DLAM,ALATT
     :        ,M,MP,J,JM,P,Q,JHEM,JHEMM)
         OMP=1.-P
         OMQ=1.-Q
C
C     Horizontal linear interpolation of theta for all NL points
C     in the vertical.
C
         F1=PLGLA(M+(JHEM-1)*MGPP,J)
         F2=PLGLA(MP+(JHEM-1)*MGPP,J)
         F3=PLGLA(MP+(JHEMM-1)*MGPP,JM)
         F4=PLGLA(M+(JHEMM-1)*MGPP,JM)
         PSURF=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1
         IF (INISURF.EQ.1) THEN
            IF (ZCLUSTER(ICL).GE.PSURF) THEN
               POSN(NTIME,ILAB,3)=0.999
               RETURN
            ENDIF
            THACC=1.E-6
            DO 10 LH=1,NL+1
               PHOUT(LH)=AETA(LH)+BETA(LH)*PSURF
 10         CONTINUE
            DO 12 L=1,NL
               THETA(L)=.5*(PHOUT(L)+PHOUT(L+1))
 12         CONTINUE
         ENDIF
         IF (INISURF.EQ.2) THEN
            THACC=1.E-4
            CALL FINDALEV(THGLA,THETA,M,MP,J,JM,P,Q,JHEM,JHEMM)
            IF (LOROG) THEN
               CALL FINDALEV(PSGLA,ZPART,M,MP,J,JM,P,Q,JHEM,JHEMM)
            ENDIF
         ENDIF
      ELSE
C
C     Find theta on each level at the particle's starting g.p.
C     for IPOSN(ICL)=1 or 2.
C
C     Set up as if for hemispheric mode and make appropriate changes
C     if particles lie in the Southern hemisphere.
C
         JHEM=1
         J=JR
         M=MR
         IF (J.GT.JG) THEN
            JHEM=2
            J=JGGP-JR
         ENDIF
         PSURF=PLGLA(M+(JHEM-1)*MGPP,J)
         IF (INISURF.EQ.1) THEN
            IF (ZCLUSTER(ICL).GE.PSURF) THEN
               POSN(NTIME,ILAB,3)=0.999
               RETURN
            ENDIF
            THACC=1.E-6
            DO 30 LH=1,NL+1
               PHOUT(LH)=AETA(LH)+BETA(LH)*PSURF
 30         CONTINUE
            DO 32 L=1,NL
               THETA(L)=.5*(PHOUT(L)+PHOUT(L+1))
 32         CONTINUE
         ENDIF
         IF (INISURF.EQ.2) THEN
            THACC=1.E-4
            DO 44 L=1,NL
               THETA(L)=THGLA(M+(JHEM-1)*MGPP+(L-1)*IGC+(J-1)*IGD)
 44         CONTINUE
            IF (LOROG) THEN
               DO 46 L=1,NL
                  ZPART(L)=PSGLA(M+(JHEM-1)*MGPP+(L-1)*IGC+(J-1)*IGD)
 46            CONTINUE
            ENDIF
         ENDIF
      ENDIF
C
C     Theta (or pressure) on each level at the particle's horizontal
C     position has now been found. Search the theta array to find L
C     such that:-
C        THETA(L) > ZCLUSTER(ICL) > THETA(L+1)
C
C     NOTE : Theta decreases with increasing L.
C
      IF ((INISURF.EQ.2).AND.(ZCLUSTER(ICL).LT.THETA(NL))) THEN
c         WRITE(LOUTP,*) 'Initial posn below ground for particle ',ILAB
c	  WRITE(LOUTP,*) THETA(NL)
	 SIGOUT=-1.
	 GOTO 70
      ENDIF
      L=NL/2
      CALL HUNT(THETA,NL,ZCLUSTER(ICL),L)
C
C     Set up the points used for cubic interpolation in the region of
C     theta value ZCLUSTER(ICL).
C
      LSTART=2
      IF (L.LT.2) THEN
         L=2
         LSTART=1
      ENDIF
      IF (L.GT.(NL-2)) THEN
         L=NL-2
         LSTART=3
      ENDIF
      DO 50 IPT=1,4
         LPT=L+IPT-2
         XA(IPT)=ALEV(LPT)
         YA(IPT)=THETA(LPT)-ZCLUSTER(ICL)
 50   CONTINUE
C
C     Use the SECANT method to find the root of (theta-ZCLUSTER) in
C     the region close to the bracketting levels (or inner 2 levels
C     which do not bracket the particle near the boundaries).
C
C                       Numerical Recipes p.250
C     The desired accuracy of (theta-ZCLUSTER) is given by THACC.
C
      FL=YA(LSTART)
      F=YA(LSTART+1)
      IF (ABS(F-FL).LT.THACC) THEN
	 F=F-THACC
      ENDIF
      IF (ABS(FL).LT.ABS(F)) THEN
         SIGOUT=XA(LSTART)
         XL=XA(LSTART+1)
         SWAP=FL
         FL=F
         F=SWAP
      ELSE
         XL=XA(LSTART)
         SIGOUT=XA(LSTART+1)
      ENDIF
C
C     Secant loop.
C
      DO 60 I=1,MAXIT
         DX=(XL-SIGOUT)*F/(F-FL)
         XL=SIGOUT
         FL=F
         SIGOUT=SIGOUT+DX
         CALL POLINT(XA,YA,4,SIGOUT,F,DF)
         IF (ABS(F).LT.THACC) GOTO 70
 60   CONTINUE
      WRITE(LOUTP,*) 'Initial surface not located for particle ',ILAB
      WRITE(LOUTP,'(5E13.5)') THETA
 70   CONTINUE

C     If the particle lies outside the range of the model levels
C     then turn the particle OFF by setting its eta-coord to zero.
C
      IF (SIGOUT.LT.0.) THEN
         POSN(NTIME,ILAB,3)=0.
      ELSE
         BOUND=1.
         IF (ILEVTYPE.GE.1) BOUND=PSURF
         IF (LOROG) THEN
C
C     Height of each level at the particle's horizontal
C     position has now been found. Search the ZPART array to find L
C     such that:-
C        ZPART(L) < PSURF < ZPART(L+1)
C
C     NOTE : ZPART increases with increasing L and PSURF contains
C     orographic height.
C
            L=2
            CALL HUNT(ZPART,NL,PSURF,L)
            IF (L.LE.1) L=1
            BOUND=ALEV(L)+(PSURF-ZPART(L))
     :           *(ALEV(L+1)-ALEV(L))/(ZPART(L+1)-ZPART(L))
         ENDIF
         IF (SIGOUT.GT.BOUND) THEN
            POSN(NTIME,ILAB,3)=0.999*BOUND
         ELSE
            POSN(NTIME,ILAB,3)=SIGOUT
         ENDIF
      ENDIF
C
      RETURN
      END
C     ***************************************************************
      SUBROUTINE READGP
C
C     Read GRID POINT wind records for use in trajectory code.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)
C      PARAMETER(IGDLAP=1,IGCP=IGC)
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
C
C     NOTES:
C
C     Should have already specified grid spacing in
C     latitude (ALAT) and vertical coordinate (ALEV).
C     Assume that grid is regular in longitude.
C
      DO 5 ICHAN=1,MAXATTR
	 REWIND(NCGP(ICHAN))
    5 CONTINUE
      IF (ILEVTYPE.LT.2) THEN
C
C     Data is given on model levels which are labelled by a
C     known pressure-based coordinate (i.e. eta or pressure).
C
         IF (IUVFORMAT.EQ.0) CALL READEC
         IF (IUVFORMAT.EQ.2) CALL READUM
         IF (IUVFORMAT.EQ.3) CALL READARB
      ELSE
C
C     Read in wind fields.
C     Below is an example. If your data is formatted differently
C     then read it and write it to the following arrays.
C
C     URHS  : d(lon)/dt
C     VRHS  : d(lat)/dt
C     SDRHS : Omega (dp/dt)
C     PSGLA : Pressure (p) on grid points.
C
C     Each of these arrays should be ordered with an inner
C     loop over MGPP, a loop over NHEM, a loop over NL and
C     finally an outer loop over JG
C     (total length IGDLA=MGPP*NHEM*NL*JG).
C
C     It is assumed during interpolation that all four of
C     these fields are given on the same grid.
C
C     WARNINGS: Without surface pressure it is not possible
C     to detect whether particles leave the bottom of the domain.
C     In addition, it is not possible to use the lower
C     boundary condition for vertical velocity.
C
         READ(INPUT,*) URHS,VRHS,SDRHS,PSGLA
      ENDIF
C
C     Change sign of the wind components for back trajectories.
C
      IF (.NOT.LFORW) THEN
         DO 10 I=1,IGDLA
            URHS(I)=-URHS(I)
            VRHS(I)=-VRHS(I)
            SDRHS(I)=-SDRHS(I)
 10      CONTINUE
      ENDIF
C
      RETURN
      END
C     *************************************************************
      SUBROUTINE RKDUMB(YSTART,N,T1,T2,NSTEPS,H)
C
C     Runge-Kutta time steps with fixed step-size.
C     Integrate the N-1 starting values YSTART, from T1 to T2.
C     H is the fixed step size and is determined from NSTEPS.
C     On output YSTART is replaced by values at the end of the
C     integration interval. DERIVS is the routine for calculating
C     the right hand side wind terms.
C
C     PATH=Storage for intermediate coords along trajectory.
C
C     Derived from routines in Numerical Recipes (pp. 550-554).
C
C
C     Must ensure that NSTSAV >= NSTEPS.
C
      PARAMETER(NSTSAV=20)
      COMMON/PATH/YP(NSTSAV,3)
C
      PARAMETER(NMAX=4)
      REAL YSTART(NMAX-1),Y(NMAX-1),DYDT(NMAX-1)
      REAL YT(NMAX-1),DYT(NMAX-1),DYM(NMAX-1)
      REAL C(NMAX),DCDT(NMAX),CT(NMAX),DCT(NMAX),DCM(NMAX)
      REAL H,HH,H6,T,TH,BOUND
C
      HH=H*0.5
      H6=H/6.
      T=T1
C
      DO 10 I=1,N-1
         Y(I)=YSTART(I)
 10   CONTINUE
C
C     Coordinate transformation.
C
      C(1)=COS(Y(2))*COS(Y(1))
      C(2)=COS(Y(2))*SIN(Y(1))
      C(3)=SIN(Y(2))
      C(4)=Y(3)
C
      DO 20 K=1,NSTEPS
C
C     Given values for N-1 variables Y (lon,lat,p) and their
C     derivatives DYDT, known at time T, use the fourth-order
C     Runge-Kutta method to advance the solution over an interval H.
C
C     The R-K integrator increments the position on the unit sphere
C     using 3-D Cartesian geometry to improve accuracy near the poles,
C     rather than using spherical polar coordinates (lon,lat).
C     Now a particle's position is given by FOUR coordinates
C     (in array C): the position on the sphere (x,y,z) and the
C     altitude (in appropriate vertical coordinate).
C
C     First step.
C
         CALL DERIVS(T,T1,T2,Y,DYDT,BOUND)
         CALL YTOC(Y,DYDT,DCDT,N)
         DO 11 I=1,N
            CT(I)=C(I)+HH*DCDT(I)
 11      CONTINUE
         CALL CTOY(YT,CT,N,BOUND)
C
C     Second step.
C
         TH=T+HH
         CALL DERIVS(TH,T1,T2,YT,DYT,BOUND)
         CALL YTOC(YT,DYT,DCT,N)
         DO 12 I=1,N
            CT(I)=C(I)+HH*DCT(I)
 12      CONTINUE
         CALL CTOY(YT,CT,N,BOUND)
C
C     Third step.
C
         CALL DERIVS(TH,T1,T2,YT,DYM,BOUND)
         CALL YTOC(YT,DYM,DCM,N)
         DO 13 I=1,N
            CT(I)=C(I)+H*DCM(I)
            DCM(I)=DCT(I)+DCM(I)
 13      CONTINUE
         CALL CTOY(YT,CT,N,BOUND)
C
C     Fourth step.
C
         CALL DERIVS(T+H,T1,T2,YT,DYT,BOUND)
C
C     Accumulate increments with proper weights.
C
         CALL YTOC(YT,DYT,DCT,N)
         DO 14 I=1,N
            C(I)=C(I)+H6*(DCDT(I)+DCT(I)+2.*DCM(I))
 14      CONTINUE
         CALL CTOY(Y,C,N,BOUND)
         T=T+H
C
C     Save intermediate trajectory coordinates.
C
         DO 16 I=1,N-1
            YP(K,I)=Y(I)
 16      CONTINUE
 20   CONTINUE
C
C     Save final positions.
C
      DO 30 I=1,N-1
         YSTART(I)=Y(I)
 30   CONTINUE
C
      RETURN
      END
C     ****************************************************************
      SUBROUTINE YTOC(Y,DY,DC,N)
C
C     Convert (d(lon)/dt,d(lat)/dt,omega) to (u,v,w,omega).
C     Omega is the vertical velocity in chosen vertical coordinates
C     (see IUVFORMAT) and u,v and w are velocity components of
C     wind on surface of the sphere in 3-D Cartesian geometry.
C     This coordinate system improves accuracy near the poles.
C
      REAL Y(N-1),DY(N-1),DC(N),CLON,CLAT,SLON,SLAT
C
      CLON=COS(Y(1))
      CLAT=COS(Y(2))
      SLON=SIN(Y(1))
      SLAT=SIN(Y(2))
      DC(1)=-CLAT*SLON*DY(1)-SLAT*CLON*DY(2)
      DC(2)=CLAT*CLON*DY(1)-SLAT*SLON*DY(2)
      DC(3)=CLAT*DY(2)
      DC(4)=DY(3)
C
      RETURN
      END
C     ******************************************************************
      SUBROUTINE CTOY(Y,C,N,BOUND)
C
C     Convert (x,y,z,p) to (lon,lat,p).
C     p refers to the vertical coordinate (see IUVFORMAT).
C
      PARAMETER(PI=3.14159265359)
      REAL Y(N-1),C(N),BOUND,F,C1,C2
C
C     Adjust 3-D Cartesian position back to sphere
C     so that x**2+y**2+z**2=1.
C
      F=1./SQRT(C(1)*C(1)+C(2)*C(2)+C(3)*C(3))
      DO 10 I=1,3
         C(I)=F*C(I)
 10   CONTINUE
      IF (ABS(C(3)).LT.1.) THEN
         Y(2)=ASIN(C(3))
         C1=C(1)/COS(Y(2))
         C2=C(2)/COS(Y(2))
         IF (ABS(C1).LT.1.) THEN
            Y(1)=ACOS(C1)
            IF (C2.LT.0.) Y(1)=2.*PI-Y(1)
         ELSE
            WRITE(*,*) ' cos(lon) = ',C1
            IF (C1.GE.1.) THEN
               Y(1)=0.
            ELSE
               Y(1)=PI
            ENDIF
         ENDIF
      ELSE
         WRITE(*,*) ' Z = ',C(3)
         Y(2)=(PI/2.00001)*NINT(C(3))
      ENDIF
C
C     Ensure that particle lies within domain.
C
      Y(3)=C(4)
      IF (Y(3).LT.0.) Y(3)=0.
      IF (Y(3).GE.BOUND) Y(3)=0.999*BOUND
C
      RETURN
      END
C     ******************************************************************
      SUBROUTINE DERIVS(T,T1,T2,Y,DYDT,BOUND)
C
C     Returns derivatives DYDT at T. DYDT are found from looking up
C     the wind fields from grid point versions of model output.
C     BOUND refers to the vertical coordinate of the lower boundary.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)
C      PARAMETER(IGDLAP=1,IGCP=IGC)
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      REAL T,T1,T2,Y(3),DYDT(3),DYDTM(3)
     :     ,P,Q,PT,QT,S,OMS,PP(NL),PM(NL)
     :     ,BOUND,BOUNDP,BOUNDM,DPSDT,ZEDGE,WEDGE
      INTEGER M,J,L,LH,MP,JM,JHEM,JHEMM,IEDGE
     :       ,MT,JT,MPT,JMT,JHEMT,JHEMMT
C
C     Time interpolation weights.
C
      S=(T-T1)/(T2-T1)
      OMS=1.-S
C
C     Find the south-west vertex of the grid box surrounding
C     the particle.
C
      CALL FINDSW(Y,ZUBZX,DLAM,ALAT
     :        ,M,MP,J,JM,P,Q,JHEM,JHEMM)
      MT=M
      MPT=MP
      JT=J
      JMT=JM
      PT=P
      QT=Q
      JHEMT=JHEM
      JHEMMT=JHEMM
      IF (IUVFORMAT.EQ.2) THEN
         CALL FINDSW(Y,ZTBZX,DLAM,ALATT
     :        ,MT,MPT,JT,JMT,PT,QT,JHEMT,JHEMMT)
      ENDIF
C
C     Find pressure on model levels if particle positions
C     and velocities are defined in pressure coordinates.
C
      IF (ILEVTYPE.EQ.0) THEN
         BOUND=1.
         DPSDT=0.
      ELSE
         IF (LOROG.OR.(ILEVTYPE.EQ.2)) THEN
            CALL FINDALEV(PSGLA,PP,MT,MPT,JT,JMT,PT,QT,JHEMT,JHEMMT)
            CALL FINDALEV(PSGLAM,PM,MT,MPT,JT,JMT,PT,QT,JHEMT,JHEMMT)
            IF (ILEVTYPE.EQ.2) THEN
               DO 10 L=1,NL
                  ALEV(L)=S*PP(L)+OMS*PM(L)
 10            CONTINUE
            ENDIF
         ENDIF
         OMP=1.-PT
         OMQ=1.-QT
         F1=PLGLAM(MT+(JHEMT-1)*MGPP,JT)
         F2=PLGLAM(MPT+(JHEMT-1)*MGPP,JT)
         F3=PLGLAM(MPT+(JHEMMT-1)*MGPP,JMT)
         F4=PLGLAM(MT+(JHEMMT-1)*MGPP,JMT)
         PSM=QT*PT*F3+QT*OMP*F4+OMQ*PT*F2+OMQ*OMP*F1
         F1=PLGLA(MT+(JHEMT-1)*MGPP,JT)
         F2=PLGLA(MPT+(JHEMT-1)*MGPP,JT)
         F3=PLGLA(MPT+(JHEMMT-1)*MGPP,JMT)
         F4=PLGLA(MT+(JHEMMT-1)*MGPP,JMT)
         PSP=QT*PT*F3+QT*OMP*F4+OMQ*PT*F2+OMQ*OMP*F1
         IF (.NOT.LOROG) THEN
            BOUND=S*PSP+OMS*PSM
            DPSDT=(PSP-PSM)/(T2-T1)
         ELSE
C
C     Height of each level at the particle's horizontal
C     position has now been found, search the PP and PM arrays
C     to find L such that:-
C        PP(L) < PSP < PP(L+1)
C
C     NOTE : PP increases with increasing L and PSP contains
C     orographic height.
C
            L=2
            CALL HUNT(PP,NL,PSP,L)
            IF (L.LE.1) L=1
            IF (L.GE.NL) L=NL-1
            BOUNDP=ALEV(L)+(PSP-PP(L))
     :            *(ALEV(L+1)-ALEV(L))/(PP(L+1)-PP(L))
            L=2
            CALL HUNT(PM,NL,PSM,L)
            IF (L.LE.1) L=1
	    IF (L.GE.NL) L=NL-1
            BOUNDM=ALEV(L)+(PSM-PM(L))
     :            *(ALEV(L+1)-ALEV(L))/(PM(L+1)-PM(L))
            BOUND=S*BOUNDP+OMS*BOUNDM
            DPSDT=(BOUNDP-BOUNDM)/(T2-T1)
         ENDIF
      ENDIF
C
C     Find L such that:-
C     Values ascend with L   ALEV(L) < Y(3) < ALEV(L+1)
C
      L=LSAV
      CALL HUNT(ALEV,NL,Y(3),L)
C
C     For extrapolation near the top/bottom boundaries.
C
      LSAV=L
      IF (L.LT.2) L=2
      IF (L.GT.(NL-2)) L=NL-2
      IF (LEVZT1) THEN
         IF (ALEV(L+1).GT.BOUND) L=L-2
      ELSE
         IF (ALEV(L).GT.BOUND) L=L+2
      ENDIF
C
C     Find grid point values for U,V at times tminus and
C     tplus, at the particles' positions.
C     Interpolation for case when particle lies in a grid box with
C     field values on all corners, and extrapolation near the
C     boundaries.
C     Remember that U,V are stored on full levels.
C
      CALL INTERP(URHS,DYDT(1),M,J,L,P,Q,Y(3),MP,JM,JHEM,JHEMM)
      CALL INTERP(VRHS,DYDT(2),M,J,L,P,Q,Y(3),MP,JM,JHEM,JHEMM)
      CALL INTERP(UM,DYDTM(1),M,J,L,P,Q,Y(3),MP,JM,JHEM,JHEMM)
      CALL INTERP(VM,DYDTM(2),M,J,L,P,Q,Y(3),MP,JM,JHEM,JHEMM)
C
      IF (ILEVTYPE.EQ.0) THEN
C
C     For ECMWF, RSGCM and UM data in eta coordinates
C     vertical velocity, etadot, is on half-levels.
C
C     Find LH such that:-
C     Values ascend with LH    ALEVH(LH) < Y(3) < ALEVH(LH+1)
C
         LH=LHSAV
         CALL HUNT(ALEVH,NL+1,Y(3),LH)
         LHSAV=LH
         IF(LHSAV.LE.1) LHSAV=2
C
C     For extrapolation near the top/bottom boundaries.
C
         IF (LH.LT.2) LH=2
         IF (LH.GT.(NL-1)) LH=NL-1
C
C     Find grid point values for SDOT, at times tminus and
C     tplus, at the particles' positions.
C     Remember that SDOT is stored on half levels.
C
         CALL HINTERP(SDRHS,DYDT(3),MT,JT,LH,PT,QT,Y(3)
     :        ,MPT,JMT,JHEMT,JHEMMT)
         CALL HINTERP(SDM,DYDTM(3),MT,JT,LH,PT,QT,Y(3)
     :        ,MPT,JMT,JHEMT,JHEMMT)
      ELSE
C
C     The vertical velocities are given on the same levels as all
C     other fields. BOUND denotes the value of vertical coordinate
C     at the lower boundary and DPSDT the vertical velocity.
C
         IEDGE=0
         ZEDGE=0.
         WEDGE=0.
         IF (LSAV.LE.1) L=1
         IF (LSAV.GE.(NL-1)) L=NL-1
         IF (.NOT.LEVZT1) THEN
            IF (ALEV(L).GT.BOUND) THEN
               L=L+1
               IEDGE=1
               ZEDGE=BOUND
               WEDGE=DPSDT
            ENDIF
            IF (L.EQ.1) THEN
               IEDGE=1
               ZEDGE=BOUND
               WEDGE=DPSDT
            ENDIF
            IF (LSAV.EQ.(NL-1)) IEDGE=2
         ELSE
            IF (ALEV(L+1).GT.BOUND) THEN
               L=L-1
               IEDGE=2
               ZEDGE=BOUND
               WEDGE=DPSDT
            ENDIF
            IF (LSAV.EQ.(NL-1)) THEN
               IEDGE=2
               ZEDGE=BOUND
               WEDGE=DPSDT
            ENDIF
            IF (LSAV.EQ.1) IEDGE=1
         ENDIF
         CALL WINTERP(SDRHS,DYDT(3),M,J,L,P,Q,Y(3)
     :        ,MP,JM,JHEM,JHEMM,IEDGE,ZEDGE,WEDGE)
         CALL WINTERP(SDM,DYDTM(3),M,J,L,P,Q,Y(3)
     :        ,MP,JM,JHEM,JHEMM,IEDGE,ZEDGE,WEDGE)
      ENDIF
C
C     Linear interpolation between tminus and tplus to particle's time.
C
      DO 40 I=1,3
         DYDT(I)=S*DYDT(I)+OMS*DYDTM(I)
 40   CONTINUE
C
      RETURN
      END
C     ******************************************************************
      SUBROUTINE FINDSW(Y,XLAM,DLAM,ALAT
     :                 ,M,MP,J,JM,P,Q,JHEM,JHEMM)
C
C     Finds the indices describing the South-West corner of
C     the grid box surrounding the particle.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      REAL Y(3),P,Q,YMOD,XLAM,DLAM,ALAT(JGG)
      INTEGER M,MP,MINT,J,JM,JHEM,JHEMM
C
C     Remember that longitude is cyclic with MOCT fold symmetry.
C
      YMOD=Y(1)-XLAM-DLAM
      NCYCLE=INT(YMOD/PI2DM)
      YMOD=YMOD-NCYCLE*PI2DM
      MINT=INT(YMOD/DLAM)
      M=MINT+1
C
C     Remember cyclic in longitude index for point to the East.
C
      IF (M.EQ.MG) THEN
         MP=1
      ELSE
         MP=M+1
      ENDIF
C
C     Use previous grid point as first guess for the new grid point at
C     vertex 1 of the grid box surrounding the particle.
C
      JM=JSAV-1
C
C     Finds J such that:-
C     Values descend with J  ALAT(J-1) > Y(2) > ALAT(J)
C
      CALL HUNT(ALAT,JGG,Y(2),JM)
      J=JM+1
C
C     Save the grid point for the next particle.
C
      JSAV=J
      IF(JSAV.LE.1) JSAV=2
C
C     For extrapolation near SP or equator and also near NP.
C
      IF (J.EQ.JGG+1) J=JGG
      IF (J.EQ.1) J=2
C
C     Set up the horizontal linear interpolation weights.
C
      P=(YMOD-MINT*DLAM)/DLAM
      DPHI=ALAT(J-1)-ALAT(J)
      IF (DPHI.EQ.0.) THEN
         J=J-1
         DPHI=ALAT(J-1)-ALAT(J)
      ENDIF
      Q=(Y(2)-ALAT(J))/DPHI
C
C     Set up as if for hemispheric mode and make appropriate changes
C     if particles lie in the Southern hemisphere.
C
      JM=J-1
      JHEM=1
      JHEMM=1
      IF (J.GT.JG) THEN
         JHEM=2
         J=JGGP-J
         IF (JM.GT.JG) THEN
            JHEMM=2
            JM=JGGP-JM
         ENDIF
      ENDIF
C
      RETURN
      END
C     *****************************************************************
      SUBROUTINE HUNT(XX,N,X,JLO)
C
C     Given an array XX of length N, and given a value X, returns a
C     value JLO such that X is between XX(JLO) and XX(JLO+1). XX must
C     be monotonic, either increasing or decreasing.
C     JLO=0 or JLO=N is returned to indicate that X is out of range.
C     JLO on input is taken as the initial guess for JLO on output.
C
C     From Numerical Recipes.
C
      DIMENSION XX(N)
      LOGICAL ASCEND
C
      ASCEND=XX(N).GT.XX(1)
C
C     Is input guess useful? If not go directly to disection.
C
      IF(JLO.LE.0.OR.JLO.GT.N) THEN
         JLO=0
         JHI=N+1
         GO TO 3
      ENDIF
C
C     Set the hunting increment.
C
      INC=1
C
C     Hunt up.
C
      IF(X.GE.XX(JLO).EQV.ASCEND) THEN
 1       JHI=JLO+INC
         IF(JHI.GT.N) THEN
            JHI=N+1
         ELSE IF(X.GE.XX(JHI).EQV.ASCEND) THEN
            JLO=JHI
            INC=INC+INC
            GO TO 1
         ENDIF
      ELSE
C
C     Hunt down.
C
         JHI=JLO
 2       JLO=JHI-INC
         IF(JLO.LT.1) THEN
            JLO=0
         ELSE IF(X.LT.XX(JLO).EQV.ASCEND) THEN
            JHI=JLO
            INC=INC+INC
            GO TO 2
         ENDIF
      ENDIF
C
C     Hunt is done so begin the final bisection phase.
C
 3    IF(JHI-JLO.EQ.1) RETURN
      JM=(JHI+JLO)/2
      IF(X.GT.XX(JM).EQV.ASCEND) THEN
         JLO=JM
      ELSE
         JHI=JM
      ENDIF
      GO TO 3
      END
C     ******************************************************************
      SUBROUTINE FINDALEV(FIN,POUT,M,MP,J,JM,P,Q,JHEM,JHEMM)
C
C     To find a field on levels at particle's horizontal position.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      REAL FIN(IGDLA),POUT(NL),P,Q,OMP,OMQ
      INTEGER M,MP,J,JM,JHEM,JHEMM
C
C     Horizontal interpolation of (non-dimensionalised)
C     field on model levels to particle's horizontal position.
C
      OMP=1.-P
      OMQ=1.-Q
      DO 10 L=1,NL
         F1=FIN(M+(JHEM-1)*MGPP+(L-1)*IGC+(J-1)*IGD)
         F2=FIN(MP+(JHEM-1)*MGPP+(L-1)*IGC+(J-1)*IGD)
         F3=FIN(MP+(JHEMM-1)*MGPP+(L-1)*IGC+(JM-1)*IGD)
         F4=FIN(M+(JHEMM-1)*MGPP+(L-1)*IGC+(JM-1)*IGD)
         POUT(L)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1
 10   CONTINUE
C
      RETURN
      END
C     ****************************************************************
      SUBROUTINE INTERP(FIN,FOUT,M,J,L,P,Q,SIG,MP,JM,JHEM,JHEMM)
C
C     Horizontal linear interpolation within a complete grid square
C     with field values on all corners.
C     Cubic vertical interpolation.
C     Serves for extrapolation when the box has been moved in from the
C     boundary.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      REAL FIN(MGPP,NHEM,NL,JG),FOUT,P,Q,OMP,OMQ,XA(4),YA(4),SIG
      INTEGER M,MP,J,L,JM,JHEM,JHEMM
C
      OMP=1-P
      OMQ=1-Q
C
C     Horizontal linear interpolation for all 4 points in the vertical.
C
      DO 10 IPT=1,4
         LPT=L+IPT-2
         F1=FIN(M,JHEM,LPT,J)
         F2=FIN(MP,JHEM,LPT,J)
         F3=FIN(MP,JHEMM,LPT,JM)
         F4=FIN(M,JHEMM,LPT,JM)
         XA(IPT)=ALEV(LPT)
         YA(IPT)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1
 10   CONTINUE
C
C     Cubic vertical interpolation.
C
      CALL POLINT(XA,YA,4,SIG,FOUT,DY)
C
      RETURN
      END
C     ****************************************************************
      SUBROUTINE HINTERP(FIN,FOUT,M,J,LH,P,Q,SIG,MP,JM,JHEM,JHEMM)
C
C     Interpolation for vertical velocity between half-levels.
C
C     NOTE: Half levels range from p=0 (LH=1) to p=psurf (LH=NL+1).
C     However vertical velocity only defined on half-levels
C     LH=2 to LH=NL+1 with level index LH-1.
C
C     Horizontal linear interpolation within a complete grid square
C     with field values on all corners.
C     Cubic vertical interpolation.
C     Serves for extrapolation when the box has been moved in from the
C     boundary.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      REAL FIN(MGPP,NHEM,NL,JG),FOUT,P,Q,OMP,OMQ,XA(4),YA(4),SIG
      INTEGER M,MP,J,LH,JM,JHEM,JHEMM
C
      OMP=1-P
      OMQ=1-Q
C
C     Find the values on each corner as numbered in notes for all 4
C     points in the vertical.
C
      IF (LH.EQ.2) THEN
C
C     Vertical velocity extrapolation at upper boundary only.
C     Use b.c. : sgotg=0 at eta=0.
C
         XA(1)=ALEVH(1)
         YA(1)=0.
         DO 10 IPT=1,3
            LPT=IPT+1
            F1=FIN(M,JHEM,IPT,J)
            F2=FIN(MP,JHEM,IPT,J)
            F3=FIN(MP,JHEMM,IPT,JM)
            F4=FIN(M,JHEMM,IPT,JM)
            XA(LPT)=ALEVH(LPT)
            YA(LPT)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1
 10      CONTINUE
      ELSE
C
C     Vertical velocity extrapolation in interior or at
C     lower boundary (for LH=NL-1). In latter case use value
C     of sdotg on eta=1 (=0 if particle positions and velocities
C     are described in eta coordinates).
C
         DO 30 IPT=1,4
            LPT=LH+IPT-2
            F1=FIN(M,JHEM,LPT-1,J)
            F2=FIN(MP,JHEM,LPT-1,J)
            F3=FIN(MP,JHEMM,LPT-1,JM)
            F4=FIN(M,JHEMM,LPT-1,JM)
            XA(IPT)=ALEVH(LPT)
            YA(IPT)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1
 30      CONTINUE
      ENDIF
C
C     Cubic vertical interpolation.
C
      CALL POLINT(XA,YA,4,SIG,FOUT,DY)
C
      RETURN
      END
C     ****************************************************************
      SUBROUTINE WINTERP(FIN,FOUT,M,J,L,P,Q,SIG
     :     ,MP,JM,JHEM,JHEMM,IEDGE,ZEDGE,WEDGE)
C
C     Interpolation for vertical velocity between levels.
C
C     NOTE: Vertical velocity is defined on levels ranging
C     from 1 to NL in eta (or p) coords.
C
C     IEDGE=0    denotes interior
C     IEDGE=1    denotes boundary at low L end.
C     IEDGE=2    denotes boundary at high L end.
C
C     ZEDGE=boundary position;   WEDGE=boundary velocity.
C
C     Horizontal linear interpolation within a complete grid square
C     with field values on all corners.
C     Cubic vertical interpolation.
C     Serves for extrapolation when the box has been moved in from the
C     boundary.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      REAL FIN(MGPP,NHEM,NL,JG),FOUT,P,Q,OMP,OMQ,XA(4),YA(4),SIG
     :    ,ZEDGE,WEDGE
      INTEGER M,MP,J,JM,JHEM,JHEMM,IEDGE
C
      OMP=1-P
      OMQ=1-Q
C
C     Find the values on each corner as numbered in notes for all 4
C     points in the vertical.
C
      IF (IEDGE.EQ.0) THEN
C
C     Vertical velocity interpolation in interior.
C
         DO 10 IPT=1,4
            LPT=L+IPT-2
            F1=FIN(M,JHEM,LPT,J)
            F2=FIN(MP,JHEM,LPT,J)
            F3=FIN(MP,JHEMM,LPT,JM)
            F4=FIN(M,JHEMM,LPT,JM)
            XA(IPT)=ALEV(LPT)
            YA(IPT)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1
 10      CONTINUE
      ELSE
         IF (IEDGE.EQ.1) THEN
C
C     Vertical velocity extrapolation at low L boundary using b.c.
C
            XA(1)=ZEDGE
            YA(1)=WEDGE
            DO 20 IPT=2,4
               LPT=L+IPT-2
               F1=FIN(M,JHEM,LPT,J)
               F2=FIN(MP,JHEM,LPT,J)
               F3=FIN(MP,JHEMM,LPT,JM)
               F4=FIN(M,JHEMM,LPT,JM)
               XA(IPT)=ALEV(LPT)
               YA(IPT)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1
 20         CONTINUE
         ELSE
C
C     Vertical velocity extrapolation at high L boundary using b.c.
C
            XA(4)=ZEDGE
            YA(4)=WEDGE
            DO 30 IPT=1,3
               LPT=L+IPT-2
               F1=FIN(M,JHEM,LPT,J)
               F2=FIN(MP,JHEM,LPT,J)
               F3=FIN(MP,JHEMM,LPT,JM)
               F4=FIN(M,JHEMM,LPT,JM)
               XA(IPT)=ALEV(LPT)
               YA(IPT)=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1
 30         CONTINUE
         ENDIF
      ENDIF
C
C     Cubic vertical interpolation.
C
      CALL POLINT(XA,YA,4,SIG,FOUT,DY)
C
      RETURN
      END
C     ****************************************************************
      SUBROUTINE POLINT(XA,YA,N,X,Y,DY)
C
C     Given arrays XA and YA, each of length N, and given a value X,
C     this routine returns a value Y, and an error estimate DY.
C     If P(X) is the polynomial degree N-1 such that
C     P(XAi)=YAi,i=1,...,N, then the returned value Y=P(X).
C
C              from Numerical Recipes, p.82.
C
      PARAMETER (NMAX=10)
      DIMENSION XA(N),YA(N),C(NMAX),D(NMAX)
 6000 FORMAT(/'Two elements of XA are identical.')
C
      NS=1
      DIF=ABS(X-XA(1))
      DO 11 I=1,N
         DIFT=ABS(X-XA(I))
         IF (DIFT.LT.DIF) THEN
            NS=I
            DIF=DIFT
         ENDIF
         C(I)=YA(I)
         D(I)=YA(I)
 11   CONTINUE
      Y=YA(NS)
      NS=NS-1
      DO 13 M=1,N-1
         DO 12 I=1,N-M
            HO=XA(I)-X
            HP=XA(I+M)-X
            W=C(I+1)-D(I)
            DEN=HO-HP
            IF (DEN.EQ.0) THEN
               WRITE(6,6000)
               STOP                 100
            ENDIF
            DEN=W/DEN
            D(I)=HP*DEN
            C(I)=HO*DEN
 12      CONTINUE
         IF (2*NS.LT.N-M) THEN
            DY=C(NS+1)
         ELSE
            DY=D(NS)
            NS=NS-1
         ENDIF
         Y=Y+DY
 13   CONTINUE
      RETURN
      END
C     ***************************************************************
      SUBROUTINE SETATTR(IPOS,ITELP)
C
C     Interpolates the attribute fields to the particles' positions.
C
C     IPOS is position marker for this release set.
C     ITELP is marker for current time element for this set.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)
C      PARAMETER(IGDLAP=1,IGCP=IGC)
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      COMMON/CLUSTERS/NCLUSTERS,IPOSN(MAXCLUS)
     :,IPOINTER(MAXCLUS)
     :,XCLUSTER(MAXCLUS),YCLUSTER(MAXCLUS),ZCLUSTER(MAXCLUS)
     :,XSPACE(MAXCLUS),YSPACE(MAXCLUS),ZSPACE(MAXCLUS)
     :,NXACR(MAXCLUS),NYACR(MAXCLUS),PHILIM,INISURF
C
      REAL Y(3),P,Q,OMP,OMQ,DS,S,OMS,PSP,PSM,THACC
     :     ,XLAM,ALATUSE(JGG)
     :     ,FIELD(IGDLA),OFIELD(IGDLA),FP,FM,PP,PM,PUP,PDOWN
      INTEGER M,MP,J,L,JM,JHEM,JHEMM,ITYPE
     :,IPOS,NTIME,ITELP,NLOOP,IEND,LH
     :,ICL
C
C     Set the particle's attribute values.
C     IATTRTYP(I)=
C     0     ;Surface pressure assigned to i'th attribute.
C     1     ;Temperature.
C     2     ;Potential temperature.
C     3     ;Ertel potential vorticity.
C     4     ;Specific humidity (LDRY=.FALSE.).
C     5     ;Tracer field no. NCHI(1) from history.
C     6     ;Tracer field no. NCHI(2) from history.
C
      FM=0.
      FP=0.
      NLOOP=NJUMP
      IF (ITELP.EQ.1) NLOOP=1
      IEND=NATTR
      IF (NATTR.EQ.0) IEND=IEND+1
      DO 10 IATTR=1,IEND
         ITYPE=IATTRTYP(IATTR)
         IF (LUGRID(IATTR)) THEN
            XLAM=ZUBZX
            DO 20 J=1,JGG
               ALATUSE(J)=ALAT(J)
 20         CONTINUE
         ELSE
            XLAM=ZTBZX
            DO 30 J=1,JGG
               ALATUSE(J)=ALATT(J)
 30         CONTINUE
         ENDIF
         IF ((IATTR.LE.NATTR).AND.(ITYPE.GT.0)) THEN
            ICHAN=NCGP(ITYPE)
            CALL READATTR(ICHAN,FIELD)
            IF (NLOOP.GT.1) THEN
               ICHAN=ICHAN+MAXATTR
               CALL READATTR(ICHAN,OFIELD)
            ENDIF
         ENDIF
C
C     Loop over particles.
C
         DO 900 II=1,NPSET
            ICL=1
	    DO 902 ICC=1,NCLUSTERS
	       IF (II.GE.IPOINTER(ICC)) THEN
	          ICL=ICC
               ENDIF
  902       CONTINUE
            ILAB=IPOS+II
C
C     Is the particle switched ON ?
C
            IF (POSN(ITELP,ILAB,3).GT.0.0) THEN
               S=1./FLOAT(NLOOP)
               DS=S
               DO 910 IINTER=1,NLOOP
                  NTIME=ITELP-NLOOP+IINTER
                  OMS=1.-S
C
C     Find the vertex of the grid box surrounding the particle which
C     has the lowest longitude,latitude and sigma.
C
                  Y(1)=POSN(NTIME,ILAB,1)
                  Y(2)=POSN(NTIME,ILAB,2)
                  Y(3)=POSN(NTIME,ILAB,3)
                  CALL FINDSW(Y,XLAM,DLAM,ALATUSE
     :                 ,M,MP,J,JM,P,Q,JHEM,JHEMM)
C
C     Find pressure on model levels if not a sigma-level model.
C
                  IF (ILEVTYPE.EQ.2) THEN
                     CALL FINDALEV(PSGLA,ALEV,M,MP,J,JM,P,Q,JHEM,JHEMM)
                  ENDIF
C
C     Find L such that:-
C     Values ascend with L   ALEV(L) < Y(3) < ALEV(L+1).
C
                  L=LSAV
                  CALL HUNT(ALEV,NL,Y(3),L)
                  IF (L.LT.2) L=2
                  LSAV=L
                  IF (L.GT.(NL-2)) L=NL-2
C
C     If isentropic initialisation has failed
C     turn the particle off.
C     This sometimes occurs where the isentropic
C     surface intersects the ground.
C
                  IF ((NTIME.EQ.1).AND.(INISURF.EQ.2)
     :                 .AND.(IATTR.EQ.1)) THEN
                     CALL INTERP(THGLA,THETA,M,J,L,P,Q,Y(3)
     :                    ,MP,JM,JHEM,JHEMM)
                     THACC=5.E-4
                     ERR=ABS(THETA-ZCLUSTER(ICL))
                     IF (ERR.GT.THACC) THEN
 6000 FORMAT(/'Isentropic init failed for particle ',I5,'  Err ',E11.4)
                        WRITE(LOUTP,6000) ILAB,ERR
                        POSN(NTIME,ILAB,3)=0.
                        GOTO 900
                     ENDIF
                  ENDIF
C
C     Calculate surface pressure at particles positions
C     if wanted as attribute or for pressure coordinate.
C
                  IF ((ITYPE.EQ.0).OR.((IATTR.EQ.1).AND.LPOUT)) THEN
                     OMP=1.-P
                     OMQ=1.-Q
                     F1=PLGLA(M+(JHEM-1)*MGPP,J)
                     F2=PLGLA(MP+(JHEM-1)*MGPP,J)
                     F3=PLGLA(MP+(JHEMM-1)*MGPP,JM)
                     F4=PLGLA(M+(JHEMM-1)*MGPP,JM)
                     PSP=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1
                     IF (IINTER.LT.NLOOP) THEN
                        F1=PLGLAM(M+(JHEM-1)*MGPP,J)
                        F2=PLGLAM(MP+(JHEM-1)*MGPP,J)
                        F3=PLGLAM(MP+(JHEMM-1)*MGPP,JM)
                        F4=PLGLAM(M+(JHEMM-1)*MGPP,JM)
                        PSM=Q*P*F3+Q*OMP*F4+OMQ*P*F2+OMQ*OMP*F1
                     ENDIF
                  ENDIF
C
C     Assign attributes.
C
                  IF (IATTR.LE.NATTR) THEN
                     IF (ITYPE.NE.0) THEN
                        CALL INTERP(FIELD,FP,M,J,L,P,Q,Y(3)
     :                       ,MP,JM,JHEM,JHEMM)
                        IF (IINTER.LT.NLOOP) THEN
                           CALL INTERP(OFIELD,FM,M,J,L,P,Q,Y(3)
     :                          ,MP,JM,JHEM,JHEMM)
                        ENDIF
                        POSN(NTIME,ILAB,3+IATTR)=S*FP+OMS*FM
                     ELSE
                        POSN(NTIME,ILAB,3+IATTR)=1000.*(S*PSP+OMS*PSM)
                     ENDIF
                  ENDIF
C
C     Record pressure at particles position if required
C     for output in place of eta.
C
                  IF ((IATTR.EQ.1).AND.LPOUT) THEN
C
C     Find LH such that:-
C     Values ascend with LH   ALEVH(LH) < Y(3) < ALEVH(LH+1).
C
                     LH=L
                     CALL HUNT(ALEVH,NL+1,Y(3),LH)
                     IF (LH.LT.1) LH=1
                     IF (LH.GT.(NL-1)) LH=NL-1
                     PUP=AETA(LH+1)+BETA(LH+1)*PSP
                     PDOWN=AETA(LH)+BETA(LH)*PSP
                     PP=(PUP-PDOWN)*(Y(3)-ALEVH(LH))
     :                       /(ALEVH(LH+1)-ALEVH(LH))+PDOWN
                     IF (IINTER.LT.NLOOP) THEN
                        PUP=AETA(LH+1)+BETA(LH+1)*PSM
                        PDOWN=AETA(LH)+BETA(LH)*PSM
                        PM=(PUP-PDOWN)*(Y(3)-ALEVH(LH))
     :                       /(ALEVH(LH+1)-ALEVH(LH))+PDOWN
                     ENDIF
                     VPOSN(NTIME,ILAB)=S*PP+OMS*PM
                  ENDIF
                  S=S+DS
 910           CONTINUE
            ENDIF
 900     CONTINUE
 10   CONTINUE
C
      RETURN
      END
C     ******************************************************************
      SUBROUTINE READATTR(ICHAN,FIELD)
C
C     Read attribute from scratch file ICHAN.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      INTEGER ICHAN
      REAL ONELAT(IGD),FIELD(IGDLA)
C
      REWIND(ICHAN)
      DO 10 J=1,JG
         READ(ICHAN) ONELAT
         DO 20 I=1,IGD
            FIELD((J-1)*IGD+I)=ONELAT(I)
 20      CONTINUE
 10   CONTINUE
C
      RETURN
      END
C     ******************************************************************
      SUBROUTINE COPYATTR(ICHAN1,ICHAN2)
C
C     Copy attribute from scratch file ICHAN1 to ICHAN2.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      INTEGER ICHAN1,ICHAN2
      REAL ONELAT(IGD)
C
      REWIND(ICHAN1)
      REWIND(ICHAN2)
      DO 10 J=1,JG
         READ(ICHAN1) ONELAT
         WRITE(ICHAN2) ONELAT
 10   CONTINUE
C
      RETURN
      END
C     ****************************************************************
      SUBROUTINE INILAT
C
C     Set latitudes.
C     Subroutine GWTLT calculates Gaussian weights and latitudes.
C     If IUVFORMAT=1 must compile with the CRAY library
C     /home/j90/kd/sgcm/sublib7.a .
C     Subroutine LEGDERV calculates Associated Legendre Functions (ALP)
C     and their derivatives (DALP) for the RS format.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/LEGAU/
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)
     :,JH,JL
C
C
      DO 10 J=1,JG
         JH=J
         IF (IGRIDTYPE.EQ.0) THEN
            CALL GWTLT(SIJ,WEIGHT,J,JG,IWORDSIZE)
            SI(J)=SIJ
            ALAT(J)=ASIN(SIJ)
         ENDIF
         IF (IGRIDTYPE.EQ.1) THEN
            ALAT(J)=.5*PI-J*.5*PI/FLOAT(JG+1)
            SI(J)=SIN(ALAT(J))
         ENDIF
         SISQ(J)=SI(J)*SI(J)
         CSSQ(J)=1.-SISQ(J)
         CS(J)=SQRT(CSSQ(J))
         SECSQ(J)=1./CSSQ(J)
         IF (IUVFORMAT.EQ.1) THEN
            GWT(J)=WEIGHT/FLOAT(NHEM)
            AW(J)=GWT(J)*FLOAT(NHEM)*2.*SECSQ(J)
            CALL LEGDERV
         ENDIF
 10   CONTINUE
      IF (NHEM.EQ.2) THEN
         DO 40 J=1,JG
            SI(JGGP-J)=-SI(J)
            CS(JGGP-J)=CS(J)
            SISQ(JGGP-J)=SISQ(J)
            CSSQ(JGGP-J)=CSSQ(J)
            SECSQ(JGGP-J)=SECSQ(J)
            ALAT(JGGP-J)=-ALAT(J)
            IF (IUVFORMAT.EQ.1) THEN
               GWT(JGGP-J)=GWT(J)
               AW(JGGP-J)=AW(J)
            ENDIF
 40      CONTINUE
      ENDIF
C
      RETURN
      END
C     ****************************************************************
      SUBROUTINE INILEV
C
C     Set up arrays detailing wind data levels and spacing.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      IF (IUVFORMAT.NE.1) THEN
C
C     For vertical interpolation, set up a modified eta value at the
C     model half levels.  This uses P0 rather than PECMWF, to obtain
C     pressure levels in the range 0 < p < P0.
C
         DO 10 L=1,NLM
            SIGMAH(L)=AETA(L+1)+BETA(L+1)
 10      CONTINUE
      ELSE
C
C     Set up sigma levels for vertical scheme.
C     Equispaced for NL <= 5.
C     Set up half-levels.
C
         STP=1./FLOAT(NL)
         IF (NL.LE.5) THEN
            DO 110 L=1,NLM
               SIGMAH(L)=L*STP
 110        CONTINUE
         ELSE
            T1=(.9375/.94-1.25)/(.9375*(SQRT(.9375)-1.))
            T2=4.+T1
            P=0.
            DO 120 L=1,NLM
               P=P+STP
               VV=P/(5.-T2*P+T1*(P**1.5))
               VV=VV*(2.-P)*(1.+.25*SIN(PI2*(P**.6)))
               SIGMAH(L)=VV
 120        CONTINUE
         ENDIF
         AETA(1)=0.
         BETA(1)=0.
         DO 130 L=1,NLM
            AETA(L+1)=0.
            BETA(L+1)=SIGMAH(L)
 130     CONTINUE
         AETA(NL+1)=0.
         BETA(NL+1)=1.
      ENDIF
C
C     Calculate half-level functions.
C
      DO 310 L=1,NL
         DBETA(L)=BETA(L+1)-BETA(L)
         CETA(L)=AETA(L+1)*BETA(L)-AETA(L)*BETA(L+1)
 310  CONTINUE
C
C     Derive remaining arrays used for vertical scheme.
C     Nomenclature is from Reading model version, based on sigma
C     co-ords.  Arrays now contain equivalents for modified eta co-ord.
C
C     Calculate spacing between half-levels and set up full-levels.
C
      S1=0.
      DO 330 L=1,NLM
         S2=SIGMAH(L)
         DSIGMA(L)=S2-S1
         SIGMA(L)=.5*(S2+S1)
         S1=S2
 330  CONTINUE
      DSIGMA(NL)=1.-SIGMAH(NLM)
      SIGMA(NL)=.5*(1.+SIGMAH(NLM))
C
C     Set values used for sigma at model levels during
C     interpolation.
C
      DO 350 L=1,NL
         ALEV(L)=SIGMA(L)
 350  CONTINUE
      ALEVH(1)=0.
      DO 360 LH=1,NLM
         ALEVH(LH+1)=SIGMAH(LH)
 360  CONTINUE
      ALEVH(NL+1)=1.
C
      RETURN
      END
C     ****************************************************************
      SUBROUTINE READREC
C
C     Read history records and then calculate the wind field in
C     grid point space for use in trajectory code.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)
C      PARAMETER(IGDLAP=1,IGCP=IGC)
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      COMMON/LEGAU/
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)
     :,JH,JL
C
      REAL CHI(IGD)
C
C     Rewind attribute scratch files.
C
      DO 10 ICHAN=1,MAXATTR
	 REWIND(NCGP(ICHAN))
   10 CONTINUE
C
C     Read spectral coefficients from GRIB spectral file.
C     Read grid point specific humidity if necessary.
C
      IF (IUVFORMAT.EQ.0) THEN
         CALL GSCOEFFS
         IF (LQATTR.AND.LGPQ) CALL GPQREAD
      ENDIF
C
C     Read spectral coefficients from RSGCM history file.
C
      IF (IUVFORMAT.EQ.1) CALL RSCOEFFS
C
C     Loop over latitude for spectral to grid transform
C     and grid point calculations.
C
      JL=1
      DO 100 IH=1,JG
C
C     Spectral to grid transform and preliminary
C     grid point calculations for GRIB winds.
C
         IF (IUVFORMAT.EQ.0) CALL GSP2GRID
C
C     Spectral to grid transform and preliminary
C     grid point calculations for RSGCM winds.
C
         IF (IUVFORMAT.EQ.1) CALL RSP2GRID
C
C     Calculate pressure on half and full eta-levels.
C     NOTE: PLG contains surface pressure by this stage.
C
         DO 320 I=1,IGC
            PLGLA(I,JL)=PLG(I)
 320     CONTINUE
         DO 330 L=1,NL+1
            DO 340 II=1,IGC
               PSGH(II,L)=AETA(L)+BETA(L)*PLG(II)
 340        CONTINUE
 330     CONTINUE
         DO 350 L=1,NL
            DO 360 II=1,IGC
               PSG(II,L)=.5*(PSGH(II,L)+PSGH(II,L+1))
 360        CONTINUE
 350     CONTINUE
C
C     Vertical velocity calculation.
C
         CALL ETADOT
C
C     Calculate Ertel PV.
C
         IF (LPVATTR) CALL PVCR
C
C     Grid point calculations for the functions of the wind field
C     which equal the Lagrangian tendencies for longitude, latitude
C     and eta/pressure (depending upon IUVFORMAT).
C     The WW factor arises from dimensionalising the wind fields.
C
         KK=(JL-1)*IGD
         IF (LFORW) THEN
            DO 400 I=1,IGD
               URHS(KK+I)=UG(I)*WW*86400.*SECSQ(IH)
               VRHS(KK+I)=VG(I)*WW*86400./CS(IH)
               SDRHS(KK+I)=SDOTG(I)*WW*86400.
 400        CONTINUE
         ELSE
            DO 410 I=1,IGD
               URHS(KK+I)=-UG(I)*WW*86400.*SECSQ(IH)
               VRHS(KK+I)=-VG(I)*WW*86400./CS(IH)
               SDRHS(KK+I)=-SDOTG(I)*WW*86400.
 410        CONTINUE
         ENDIF
C
C     Write single latitude grid point arrays to scratch files
C     for the attributes.
C
C     Store temperature and potential temperature.
C
         IF (LTATTR) THEN
            DO 420 L=1,NL
               LL=(L-1)*IGC
               DO 425 I=1,IGC
                  PMKG=PSG(I,L)**(-AKAP)
                  TG(LL+I)=TG(LL+I)*CT
                  THG(LL+I)=TG(LL+I)*PMKG
                  THGLA(KK+LL+I)=THG(LL+I)
 425           CONTINUE
 420        CONTINUE
            WRITE(NCGP(1)) TG
            WRITE(NCGP(2)) THG
         ENDIF
C
C     Store Ertel PV.
C
         IF (LPVATTR) THEN
            DO 430 I=1,IGD
               EPVG(I)=EPVG(I)*CERT
 430        CONTINUE
            WRITE(NCGP(3)) EPVG
         ENDIF
C
C     Store specific humidity.
C
         IF (LQATTR.AND.(.NOT.LGPQ)) THEN
            DO 440 I=1,IGD
               QG(I)=QG(I)*CQ
 440        CONTINUE
            WRITE(NCGP(4)) QG
         ENDIF
C
C     Store tracer fields.
C
         IF (LTRACSWITCH) THEN
            IF (NCHI(1).LE.NTRAC) THEN
               KTRA=(NCHI(1)-1)*IGD
               DO 450 I=1,IGD
                  CHI(I)=TRAG(KTRA+I)*CTRA(NCHI(1))
 450           CONTINUE
               WRITE(NCGP(5)) CHI
            ENDIF
            IF (NCHI(2).LE.NTRAC) THEN
               KTRA=(NCHI(2)-1)*IGD
               DO 460 I=1,IGD
                  CHI(I)=TRAG(KTRA+I)*CTRA(NCHI(2))
 460           CONTINUE
               WRITE(NCGP(6)) CHI
            ENDIF
         ENDIF
C
         JL=JL+1
 100  CONTINUE
C
      RETURN
      END
C     *****************************************************************
      SUBROUTINE ETADOT
C
C     Calculate etadot (vertical velocity in eta-coords) on
C     half-levels.
C     UGCM: hybrid sigma/pressure co-ordinate.
C     Follows ECMWF Research Manual 2, section 2.2.2.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      COMMON/LEGAU/
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)
     :,JH,JL
C
      REAL OMSRF(IGC),VGP,GVDP,DETADP
C
C     Preset etadot grid array.
C
      DO 10 I=1,IGD
         SDOTG(I)=0.
   10 CONTINUE
C
C     Main loop over latitude pair.
C
      DO 100 IHEM=1,NHEM
         IOF=(IHEM-1)*MGPP
C
C     Preset surface pressure tendency.
C
         DO 20 I=1,MG
            II=I+IOF
            OMSRF(II)=0.
 20      CONTINUE
C
C     Surface omega (surface pressure tendency) from
C     integral of continuity equation.
C
         DO 30 L=1,NLM
            KK=(L-1)*IGC
            DO 40 I=1,MG
               II=I+IOF
               K=KK+II
               VGP=SECSQ(JL)*(UG(K)*PMG(II)+VG(K)*PJG(II))
               GVDP=DG(K)*(PSGH(II,L+1)-PSGH(II,L))
     ;              +PLG(II)*DBETA(L)*VGP
               OMSRF(II)=OMSRF(II)-GVDP
               SDOTG(K)=OMSRF(II)
 40         CONTINUE
 30      CONTINUE
         KK=(NL-1)*IGC
         DO 50 I=1,MG
            II=I+IOF
            K=KK+II
            VGP=SECSQ(JL)*(UG(K)*PMG(II)+VG(K)*PJG(II))
            GVDP=DG(K)*(PSGH(II,NL+1)-PSGH(II,NL))
     ;           +PLG(II)*DBETA(NL)*VGP
            OMSRF(II)=OMSRF(II)-GVDP
 50      CONTINUE
C
C     Combine surface pressure tendency and integral in SDOTG.
C
         DO 90 L=1,NLM
            KK=(L-1)*IGC
            DO 80 I=1,MG
               II=I+IOF
               K=KK+II
               DETADP=(ALEVH(L+2)-ALEVH(L))/(PSGH(II,L+2)-PSGH(II,L))
               SDOTG(K)=DETADP*( -BETA(L+1)*OMSRF(II)+SDOTG(K) )
 80         CONTINUE
 90      CONTINUE
 100  CONTINUE
C
      RETURN
      END
C     *****************************************************************
      SUBROUTINE PVCR
C
C     Calculate Ertel potential vorticity on model levels.
C     For hybrid pressure-sigma vertical co-ordinate.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      COMMON/COMGRM/DUDLSG(IGC,NL),DVDLSG(IGC,NL),DTDLSG(IGC,NL)
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      COMMON/LEGAU/
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)
     :,JH,JL
C
      REAL ECDP(NL),ECB(NL)
C
      CALL DLSGCR(IGC,UG,RGG,DUDLSG,IGC,NL)
      CALL DLSGCR(IGC,VG,RGG,DVDLSG,IGC,NL)
      CALL DLSGCR(IGC,TG,RGG,DTDLSG,IGC,NL)
      DO 100 IHEM=1,NHEM
         IOF=(IHEM-1)*MGPP
C
C     Calculate PV on model levels.
C     Generalised formula using array of model level pressures.
C     Note that the reference pressure for adiabatic processes is
C     assumed to be P0, the non-dimensionalising pressure.
C
         DO 10 I=1,MG
            II=I+IOF
            ECDP(1)=PSGH(II,2)-PSGH(II,1)
            ECB(1)=0.
            DO 2 L=2,NL
               ECDP(L)=PSGH(II,L+1)-PSGH(II,L)
               ECB(L)=ALOG(PSGH(II,L+1)/PSGH(II,L))
 2          CONTINUE
            DO 4 L=1,NL
               K=(L-1)*IGC+II
               PMKG=PSG(II,L)**(-AKAP)
               GPFAC=(DBETA(L)+CETA(L)*ECB(L)/ECDP(L))*PLG(II)/ECDP(L)
               EDPDE=SIGMA(L)*ECDP(L)/DSIGMA(L)
               PFACT=PMKG/EDPDE
               AKT=AKAP*TG(K)
               TXP=TXG(K)-AKT*GPFAC*PMG(II)
               TYP=TYG(K)-AKT*GPFAC*PJG(II)
               EPVG(K)=PFACT*(ZG(K)*(-DTDLSG(II,L)+AKT*EDPDE/PSG(II,L))
     :              +SECSQ(JH)*(-DUDLSG(II,L)*TYP+DVDLSG(II,L)*TXP))
 4          CONTINUE
 10      CONTINUE
C
 100  CONTINUE
C
      RETURN
      END
C     *****************************************************************
      SUBROUTINE DLSGCR(NCOL,F,RGG,DF,IDIM,NL)
C
C     Black-box routine to take vertical derivative of a 2D array
C     in the model's vertical co-ordinates using the RGG matrix:
C
C              DF   =   RGG   *   F
C
C     gives    DF   =   d(F)/dln(sigma)   =   (sigma)d(F)/d(sigma).
C
C     Calculates DF at NL levels for NCOL columns from the array F.
C     Uses vector loops over NCOL at each level.  Note that for
C     NCOL <= 3 inner loops unroll to give vectorisation over levels.
C
C     Uses explicit values of RGG matrix rather than function SDOT
C     over NL elements of RGG at each level.  Due to sparse nature
C     of RGG, this gives large speed-up for NL >> 3.
C
C     Reading model - sigma.
C
      REAL F(IDIM,NL),DF(IDIM,NL),RGG(NL,NL)
C
 6900 FORMAT(/' ***ABORT IN DLSGCR: MORE COLUMNS THAN ARRAY DIMENSION:'
     :       ,' NCOL IDIM =',2I10)
C
      IF (NCOL.GT.IDIM) THEN
         WRITE(2,6900) NCOL,IDIM
         CALL ABORT
      ENDIF
C
      NLM=NL-1
      NLMM=NL-2
C     Top and bottom levels.
      DO 10 I=1,NCOL
      DF(I,1 )=F(I,1)*RGG(1,1)+F(I,2)*RGG(2,1)+F(I,3)*RGG(3,1)
      DF(I,NL)=F(I,NLMM)*RGG(NLMM,NL)+F(I,NLM)*RGG(NLM,NL)
     :        +F(I,NL)*RGG(NL,NL)
   10 CONTINUE
C     Intermediate levels.
      DO 20 L=2,NLM
      DO 20 I=1,NCOL
      DF(I,L)=F(I,L-1)*RGG(L-1,L)+F(I,L+1)*RGG(L+1,L)
   20 CONTINUE
C
      RETURN
      END
C     *******************************************************
      SUBROUTINE MAKENAME(FSTEM,IOFFSET,INPFNAME,NCDATE,LGPQ)
C
C     Determine filename for next record.
C
C     Calls: IDATXC, CDXDAT - taken from Package X by Roger Brugge.
C     Calls: IDATXC2000, CDXDAT2000 - handle any date > 1/1/1900.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
      INTEGER NEWCD,KY,KM,KD,KH,NCDATE
     :       ,IPOSTSP,ISTERA,IENDERA
      REAL STCD,RNEWCD
      LOGICAL LGPQ
      CHARACTER*80 FSTEM,INPFNAME
C
C     Find century days for start date and latest time.
C
      IF (ISYY.GT.99) THEN
         STCD=FLOAT(IDATXC2000(ISDD,ISMM,ISYY))+FLOAT(ISHH)/24.
      ELSE
         STCD=FLOAT(IDATXC(ISDD,ISMM,ISYY))+FLOAT(ISHH)/24.
      ENDIF
      TIMEINT=DAY-BEGDAY
      IF (.NOT.LFORW) TIMEINT=-TIMEINT
      RNEWCD=STCD+TIMEINT
      NEWCD=INT(RNEWCD+.00001)
C
C     Convert back to YYMMDDHH.
C
      KH=NINT(24.*(RNEWCD-FLOAT(NEWCD)))
      IF (ISYY.GT.99) THEN
         CALL CDXDAT2000(NEWCD,KD,KM,KY)
      ELSE
         CALL CDXDAT(NEWCD,KD,KM,KY)
         KY=MOD(KY,100)
      ENDIF
      NCDATE=KY*1000000+KM*10000+KD*100+KH
C
C     Make filename for next record.
C
      INPFNAME=FSTEM
      IF (ISYY.GT.99) THEN
         WRITE(INPFNAME(IOFFSET:IOFFSET+9),'(I10)') NCDATE
         LGPQ=.TRUE.
      ELSE
         WRITE(INPFNAME(IOFFSET:IOFFSET+7),'(I8)') NCDATE
C
C     Test for type of specific humidity data based on dates.
C
      IPOSTSP=IDATXC(04,04,95)
      ISTERA=IDATXC(01,01,79)
      IENDERA=IDATXC(28,02,94)
      LGPQ=.FALSE.
      IF (NEWCD.GE.IPOSTSP) THEN
         LGPQ=.TRUE.
      ELSE
         IF (LERA.AND.(NEWCD.GE.ISTERA).AND.(NEWCD.LE.IENDERA)) THEN
            LGPQ=.TRUE.
         ENDIF
      ENDIF
      ENDIF
C
      RETURN
      END
C     **************************************************************
      SUBROUTINE INIGS
C
C     Set up for GRIB spectral history data (from ECMWF).
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
      COMMON/COMFFT/NTWG,NRSTWG,TRIG(IDA),WORK(IDF),IFAX(10)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      COMMON/POLYNO/POLYF(NWJ2,NHEM),CMPA(IGL)
      COMPLEX CMPA
C
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)
C
      PARAMETER(JLATS=2*(JG+1)+1,ILEN4=MG*JLATS)
      INTEGER IREC,IREM,INPFEND,IFIELD,KLEV,ISTAT
      DIMENSION SPARR(JPFLSH),ZSEC4(ILEN4)
C
 6110 FORMAT(/' LATITUDES (DEGREES)'/(15F7.3))
 6120 FORMAT(/' SIGMA AT HALF LEVELS'/(15F7.4))
 6130 FORMAT(/' SIGMA AT FULL LEVELS'/(15F7.4))
 6140 FORMAT(/' PRESSURE AT DATA LEVELS'/(15F7.4))
C
C     Determine channel for required GRIB spectral file.
C     Find filename for channel.
C
      IREC=NINT((DAY-BEGDAY)/THIST)
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)
      INPFEND=IOFFSET+7
      IF (ISYY.GT.99) INPFEND=IOFFSET+9
      IF (IREM.EQ.0) THEN
         CALL MAKENAME(FSTEM,IOFFSET,INPFNAME,NCDATE,LGPQ)
         WRITE(INPFNAME(INPFEND+1:INPFEND+4),'(A4)') '.grb'
         INPFEND=INPFEND+4
         WRITE(LOUTP,*) 'Assuming file ',INPFNAME(1:INPFEND)
     :        ,' is Cray unblocked'
         ISTAT=0
C
C     Note that PBOPEN will change the channel number INPUT.
C
         CALL PBOPEN(INPUT,INPFNAME(1:INPFEND),'r',ISTAT)
         IF(ISTAT.NE.0) THEN
            WRITE(LOUTP,*) 'Error opening file ',INPFNAME(1:INPFEND)
            WRITE(LOUTP,*) 'PBOPEN returns ISTAT = ',ISTAT
            WRITE(LOUTP,*) 'Called from INIGS'
            CALL ABORT
         ELSE
            PRINT *,INPFNAME(1:INPFEND),' OPENED'
         ENDIF
      ENDIF
C
C     Set up levels for vertical scheme.
C
      IF (ILEVTYPE.EQ.0) THEN
C
C     ECMWF eta-levels (GRIB level code 109).
C
         IFIELD=-1
         CALL SPUNPACK(SPARR,JPFLSH,INPUT,IFIELD,KLEV)
         CALL INILEV
         WRITE(LOUTP,6120) SIGMAH
         WRITE(LOUTP,6130) SIGMA
      ENDIF
      IF (ILEVTYPE.EQ.1) THEN
C
C     Standard pressure levels (GRIB level code 100).
C
C     Loop over variables Z,T,U,V,Q,W for all levels.
C     NOTE: these records contain relative humidity.
C
         IFIELD=0
         DO 100 L=1,NL
            DO 105 IVAR=1,6
               CALL SPUNPACK(ZSEC4,ILEN4,INPUT,IFIELD,KLEV)
 105        CONTINUE
            ALEV(L)=FLOAT(KLEV)/1000.
            SIGMA(L)=ALEV(L)
 100     CONTINUE
         ALEVH(1)=0.
         ALEVH(NL+1)=0.
         DO 110 L=1,NLM
            ALEVH(L+1)=0.
            SIGMAH(L)=0.
 110     CONTINUE
         WRITE(LOUTP,6140) SIGMA
      ENDIF
C
C     Close input file.
C
      IF (IREM.EQ.0) THEN
         ISTAT=0
         CALL PBCLOSE(INPUT,ISTAT)
         IF(ISTAT.NE.0) THEN
            WRITE(LOUTP,*) 'ERROR CLOSING FILE ',INPFNAME(1:INPFEND)
            WRITE(LOUTP,*) 'ISTAT = ',ISTAT
            CALL ABORT
         ENDIF
      ENDIF
C
C     Derive spectral constants from resolution parameters.
C
      MF=MM-1
      MFP=MM
      MFPP=MM+1
      NF=NN-1
      NFP=NN
      NFPP=NN+1
C
C     Spectral arrays for Legendre transforms.
C
      SQ(1)=0.
      RSQ(1)=0.
      DO 12 NP=2,NN+2
         SQ(NP)=NP*(NP-1)
         RSQ(NP)=1./SQ(NP)
 12   CONTINUE
C
C     Set up latitudes.
C     If winds are on a Gaussian grid set up
C     Legendre functions also.
C
      CALL INILAT
      WRITE(LOUTP,6110) (ALAT(J)*180./PI,J=JG,1,-1)
C
C     Array to calculate x-derivatives of Fourier coefficients.
C
      DO 20 I=1,IGL
  20  CMPA(I)=0.
      NROW=0
      DO 30 MP=1,MFP,MOCT
      NROW=NROW+1
      CMPA(NROW)=CMPLX(0.,FLOAT(MP-1))
      IF (NHEM.EQ.2) CMPA(NROW+IDL)=CMPA(NROW)
  30  CONTINUE
C
C     Normalisation for m=0,n=1 coefficient used to obtain
C     planetary vorticity.
C
      EZR=1./SQRT(.75)
C
C     Set up variables used for FFT99.
C
      CALL SET99(TRIG,IFAX,MG)
C
C     Assume that ECMWF records contain specific humidity.
C
      LDRY=.FALSE.
      LGPQ=.FALSE.
C
      RETURN
      END
C     ***************************************************************
C
C     Calculates the Gaussian latitudes and weights.
C
C     Copy of the library version in ~kd/sgcm/sublib7.npl in order
C     to avoid the library call.
C
      SUBROUTINE GWTLT(SIT,WEIGHT,J,JG,IWORDSIZE)
C
      PARAMETER(PI=3.14159265359)
      DOUBLE PRECISION ACC,SA,SB,SC,D1,D2,D4,BN,GG,X,AMM,AMN,
     1 EM,ANN,RE,A,DD,DLT,DTH
C
C     For 64-bit, double precision arithmetic ACC=1.0D-23.
C     For 32-bit, double precision arithmetic ACC=1.0D-16.
C
      IF (IWORDSIZE.EQ.8) THEN
         ACC=1.0D-23
      ELSE
         ACC=1.0D-16
      ENDIF
      SA=DSQRT(.5D0)
      SB=DSQRT(1.5D0)
      SC=DSQRT(1.D0/3.D0)
      D1=1.D0
      D2=2.D0
      D4=4.D0
      NNN=JG+JG
      BN=NNN
      GG=D2*BN+D1
      HH=8.*BN*BN
      K=0
      AJ=J
      TH=PI*(2.*AJ-.5)/GG
      DTH=TH+(COS(TH)/SIN(TH))/HH
      X=DCOS(DTH)
54    CONTINUE
      AMM=SA
      AMN=X*SB
      EM=SC
      ANN=D1
      DO 51 N=2,NNN
      ANN=ANN+D1
      RE=DSQRT(D4*ANN*ANN-D1)/ANN
      A=RE*(X*AMN-EM*AMM)
      AMM=AMN
      AMN=A
      EM=D1/RE
51    CONTINUE
      DD=GG*EM*AMM-X*ANN*A
      K=K+1
      DLT=(D1-X*X)*A/DD
      IF (DABS(DLT).LT.ACC) GOTO 52
      IF (K.GT.50) GOTO 53
      X=X-DLT
      GOTO 54
53    CONTINUE
      WRITE (2,105)
105   FORMAT(15H NO CONVERGENCE)
52    CONTINUE
      WEIGHT=GG*(D1-X*X)/(DD*DD)
      SIT=X
      RETURN
      END
      INTEGER FUNCTION NLEAD(STRING)
      CHARACTER STRING*(*),SPACE
      PARAMETER(SPACE=' ')
      NLEAD=0
      DO 100 J=1,LEN(STRING)
      IF(STRING(J:J).NE.SPACE)RETURN
      NLEAD=J
 100  CONTINUE
      END
C     ******************************************************
      SUBROUTINE GSCOEFFS
C
C     Read data from GRIB spectral files.
C
C     Adapted from R.Brugge's Package X.
C     Importantly flat triangular truncation is used.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)
C
      INTEGER JPACK
      PARAMETER(JPSEC0=2,JPSEC1=60,JPSEC2=384,JPSEC3=2,JPSEC4=42,
     -      JPZ2=12+2*NL,JPZ3=2,JPACK=280000)
C-----------------------------------------------------------------------
C     LIMITS ON GRIB PARAMETERS
C
C     NAME    MEANING
C     ----    -------
C     JPSEC0  Maximum size for ISEC0
C     JPSEC1  Maximum size for ISEC1
C     JPSEC2  Maximum size for ISEC2
C     JPSEC3  Maximum size for ISEC3
C     JPSEC4  Maximum size for ISEC4
C     JPZ2    Maximum size for ZSEC2
C     JPZ3    Maximum size for ZSEC3
C     JPACK=280000 is large enough for T213 data
C-----------------------------------------------------------------------
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
      COMMON/RESPECTR/RZ(JPFLSH,NL),RD(JPFLSH,NL),RT(JPFLSH,NL)
     :,RQ(JPFLSH,NL),RSP(JPFLSH)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
C
      INTEGER INPFEND,KLEV
      INTEGER IFIELD,ISTAT
      INTEGER NVAR
      DIMENSION ZSEC4(JPFLSH)
C
C     Determine channel for required GRIB spectral file.
C     Find filename for channel.
C
      IREC=NINT((DAY-BEGDAY)/THIST)
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)
      INPFEND=IOFFSET+7
      IF (ISYY.GT.99) INPFEND=IOFFSET+9
      IF (IREM.EQ.0) THEN
         CALL MAKENAME(FSTEM,IOFFSET,INPFNAME,NCDATE,LGPQ)
         WRITE(INPFNAME(INPFEND+1:INPFEND+4),'(A4)') '.grb'
         INPFEND=INPFEND+4
         WRITE(LOUTP,*) 'Assuming file ',INPFNAME(1:INPFEND)
     :        ,' is Cray unblocked'
         ISTAT=0
C
C     Note that PBOPEN will change the channel number INPUT.
C
         CALL PBOPEN(INPUT,INPFNAME(1:INPFEND),'r',ISTAT)
         IF(ISTAT.NE.0) THEN
            WRITE(LOUTP,*) 'Error opening file ',INPFNAME(1:INPFEND)
            WRITE(LOUTP,*) 'PBOPEN returns ISTAT = ',ISTAT
            WRITE(LOUTP,*) 'Called from GSCOEFFS'
            CALL ABORT
         ELSE
            PRINT *,INPFNAME(1:INPFEND),' OPENED'
         ENDIF
      ENDIF
      IF (LGPQ) THEN
         NVAR=4
      ELSE
         NVAR=5
      ENDIF
C
C     Unpack ln(surface pressure).
C
      IFIELD=0
      CALL SPUNPACK(RSP,JPFLSH,INPUT,IFIELD,KLEV)
      WRITE(LOUTP,*) 'First field = ',IFIELD
C
C     Loop over variables T,Q,Z,D for all levels.
C
      DO 440 L=1,NL
         DO 450 IVAR=1,NVAR
            CALL SPUNPACK(ZSEC4,JPFLSH,INPUT,IFIELD,KLEV)
C
C     Write single level spectral field to appropriate array.
C     The fields are non-dimensionalised for later grid point
C     calculations.
C
C      WRITE(LOUTP,*) 'Level = ',L,' Field = ',IFIELD
            IF (IFIELD.EQ.138) THEN
               DO 300 I=1,JPFLSH
                  RZ(I,L)=ZSEC4(I)/WW
 300           CONTINUE
            ENDIF
            IF (IFIELD.EQ.155) THEN
               DO 310 I=1,JPFLSH
                  RD(I,L)=ZSEC4(I)/WW
 310           CONTINUE
            ENDIF
            IF (IFIELD.EQ.130) THEN
               DO 320 I=1,JPFLSH
                  RT(I,L)=ZSEC4(I)/CT
 320           CONTINUE
            ENDIF
            IF (IFIELD.EQ.133) THEN
               DO 330 I=1,JPFLSH
                  RQ(I,L)=ZSEC4(I)/CQ
 330           CONTINUE
            ENDIF
C
 450     CONTINUE
         IF (L.EQ.1) THEN
            CALL SPUNPACK(RSP,JPFLSH,INPUT,IFIELD,KLEV)
            WRITE(LOUTP,*) 'Last field = ',IFIELD
         ENDIF
 440  CONTINUE
C
C     Close input file.
C
      IF (IREM.EQ.NRECPFILE-1) THEN
         ISTAT=0
         CALL PBCLOSE(INPUT,ISTAT)
         IF(ISTAT.NE.0) THEN
            WRITE(LOUTP,*) 'ERROR CLOSING FILE ',INPFNAME(1:INPFEND)
            WRITE(LOUTP,*) 'ISTAT = ',ISTAT
            CALL ABORT
         ENDIF
      ENDIF
C
      RETURN
      END
C     ***************************************************************
      SUBROUTINE GPQREAD
C
C     Read specific humidity data from GRIB Gaussian grid.
C
C     Adapted from R.Brugge's Package X.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)
C
      INTEGER JPACK
      PARAMETER(JPSEC0=2,JPSEC1=60,JPSEC2=384,JPSEC3=2,JPSEC4=42,
     -      JPZ2=12+2*NL,JPZ3=2,JPACK=280000)
C-----------------------------------------------------------------------
C     LIMITS ON GRIB PARAMETERS
C
C     NAME    MEANING
C     ----    -------
C     JPSEC0  Maximum size for ISEC0
C     JPSEC1  Maximum size for ISEC1
C     JPSEC2  Maximum size for ISEC2
C     JPSEC3  Maximum size for ISEC3
C     JPSEC4  Maximum size for ISEC4
C     JPZ2    Maximum size for ZSEC2
C     JPZ3    Maximum size for ZSEC3
C     JPACK=280000 is large enough for T213 data
C-----------------------------------------------------------------------
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
C
      PARAMETER(ILEN4=MG*JGG)
      INTEGER IREC,IREM,INPFEND,IFIELD,KLEV,ISTAT
      DIMENSION ZSEC4(ILEN4),QGLA(MG,JGG,NL)
      INTEGER NVAR
C
C     Determine channel for required GRIB spectral file.
C     Find filename for channel.
C
      IREC=NINT((DAY-BEGDAY)/THIST)
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)
      INPFEND=IOFFSET+7
      IF (ISYY.GT.99) INPFEND=IOFFSET+9
      IF (IREM.EQ.0) THEN
         CALL MAKENAME(FSTEM2,IOFFSET,INPFNAME,NCDATE,LGPQ)
         WRITE(INPFNAME(INPFEND+1:INPFEND+4),'(A4)') '.grb'
         INPFEND=INPFEND+4
         WRITE(LOUTP,*) 'Assuming file ',INPFNAME(1:INPFEND)
     :        ,' is Cray unblocked'
         ISTAT=0
C
C     Note that PBOPEN will change the channel number INPUT.
C
         CALL PBOPEN(INPUT2,INPFNAME(1:INPFEND),'r',ISTAT)
         IF(ISTAT.NE.0) THEN
            WRITE(LOUTP,*) 'Error opening file ',INPFNAME(1:INPFEND)
            WRITE(LOUTP,*) 'PBOPEN returns ISTAT = ',ISTAT
            WRITE(LOUTP,*) 'Called from GPQREAD'
            CALL ABORT
         ELSE
            PRINT *,INPFNAME(1:INPFEND),' OPENED'
         ENDIF
      ENDIF
C
C     Unpack specific humidity data.
C
      NVAR=2
      DO 10 L=1,NL
      DO 12 IVAR=1,NVAR
         IFIELD=0
         CALL SPUNPACK(ZSEC4,ILEN4,INPUT2,IFIELD,KLEV)
C      WRITE(LOUTP,*) 'Level = ',L,' Field = ',IFIELD
      IF (IFIELD.EQ.133) THEN
         II=0
         DO 20 J=1,JGG
            DO 30 I=1,MG
               II=II+1
               QGLA(I,J,L)=ZSEC4(II)
 30         CONTINUE
 20      CONTINUE
      ENDIF
 12   CONTINUE
 10   CONTINUE
C
C     Write specific humidity to a scratch file.
C
      INORTH=0
      ISOUTH=MGPP
      DO 40 J=1,JG
         JSOUTH=JGGP-J
         DO 50 L=1,NL
            LL=(L-1)*IGC
            DO 60 I=1,MG
               QG(LL+INORTH+I)=QGLA(I,J,L)
               QG(LL+ISOUTH+I)=QGLA(I,JSOUTH,L)
 60         CONTINUE
 50      CONTINUE
         WRITE(NCGP(4)) QG
 40   CONTINUE
C
C     Close input file.
C
      IF (IREM.EQ.0) THEN
         ISTAT=0
         CALL PBCLOSE(INPUT2,ISTAT)
         IF(ISTAT.NE.0) THEN
            WRITE(LOUTP,*) 'ERROR CLOSING FILE ',INPFNAME(1:INPFEND)
            WRITE(LOUTP,*) 'ISTAT = ',ISTAT
            CALL ABORT
         ENDIF
      ENDIF
C
      RETURN
      END
C     ***************************************************************
      SUBROUTINE SPUNPACK(ZSEC4,ILEN4,ICHAN,IFIELD,ILEV)
C
C     Read and unpack data from GRIB spectral files.
C
C     Adapted from R.Brugge's Package X.
C     Importantly flat triangular truncation is used.
C
C     NOTE: CHANS/IWORDSIZE is number of bytes per INTEGER word.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)
C
      INTEGER JPACK
      PARAMETER(JPSEC0=2,JPSEC1=60,JPSEC2=384,JPSEC3=2,JPSEC4=42,
     -      JPZ2=12+2*NL,JPZ3=2,JPACK=280000)
C-----------------------------------------------------------------------
C     LIMITS ON GRIB PARAMETERS
C
C     NAME    MEANING
C     ----    -------
C     JPSEC0  Maximum size for ISEC0
C     JPSEC1  Maximum size for ISEC1
C     JPSEC2  Maximum size for ISEC2
C     JPSEC3  Maximum size for ISEC3
C     JPSEC4  Maximum size for ISEC4
C     JPZ2    Maximum size for ZSEC2
C     JPZ3    Maximum size for ZSEC3
C     JPACK=280000 is large enough for T213 data
C-----------------------------------------------------------------------
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
C
      INTEGER INP(JPACK),ILEN4,ICHAN,IFIELD,ISTAT,ILENB1,ILEN1
      INTEGER ILEV,NLEVPAR,JLATS
      LOGICAL LETASET
      REAL DLAMTEST,DPHITEST
      LOGICAL LOINFO
      DIMENSION ISEC0(JPSEC0),ISEC1(JPSEC1),ISEC2(JPSEC2),
     -      ISEC3(JPSEC3),ISEC4(JPSEC4)
      DIMENSION ZSEC2(JPZ2),ZSEC3(JPZ3),ZSEC4(ILEN4)
C
C
C     Use negative IFIELD to indicate that eta level
C     info must be copied to ALEVH.
C
      IF (IFIELD.LT.0) THEN
         LETASET=.TRUE.
      ELSE
         LETASET=.FALSE.
      ENDIF
      ISTAT=0
      ILENB1=IWORDSIZE*JPACK
      CALL PBGRIB(ICHAN,INP,ILENB1,ILEN1,ISTAT)
      ILEN=ILEN1/IWORDSIZE
      IF (MOD(ILEN1,IWORDSIZE).NE.0) ILEN=ILEN+1
      IF (ISTAT.EQ.0) THEN
         LOINFO=.FALSE.
         CALL RDGRIB(INP,JPACK,LOINFO,IDATE,IFIELD,ILEV,
     -        ISEC0,ISEC1,ISEC2,ISEC3,ISEC4,ZSEC2,ZSEC3,ZSEC4,
     -        ILEN4)
      ELSEIF (ISTAT.EQ.-1) THEN
         WRITE(LOUTP,*)'END-OF-FILE HAS BEEN REACHED'
      ELSE
         WRITE(LOUTP,*)'SIZE OF BUFFER IS NOT SUFFICIENT'
         CALL ABORT
      ENDIF
C
C     Check whether data is formed of spectral harmonics.
C
      IF(ISEC2(1).EQ.50) THEN
         IF(.NOT.LSPECTRAL) THEN
            WRITE(LOUTP,*)'SPECTRAL FIELD DETECTED'
            STOP
         ENDIF
C
C     Check input truncation.
C
         ITRUNC=ISEC2(2)
         ITRUN2=ISEC2(3)
         ITRUN3=ISEC2(4)
         IF(ITRUNC.NE.ITRUN2.OR.ITRUNC.NE.ITRUN3) THEN
            WRITE(LOUTP,*)'INPUT FIELD NOT TRIANGULAR TRUNCATION'
            CALL ABORT
         ENDIF
         IF(ITRUNC.NE.NN) THEN
            WRITE(LOUTP,*)'INPUT FIELD TRUNCATION DOES NOT MATCH NN'
            CALL ABORT
         ENDIF
      ENDIF
C
C     Check to see if grid is regular lon-lat.
C
      IF(ISEC2(1).EQ.0) THEN
         WRITE(LOUTP,*)'Data is on a regular lon-lat grid.'
         IF (ISEC2(2).NE.MG) THEN
            WRITE(LOUTP,1001) ISEC2(2),MG
            STOP
         ENDIF
         JLATS=ILEN4/MG
         IF (ISEC2(3).NE.JLATS) THEN
            WRITE(LOUTP,1002) ISEC2(3),JLATS
            STOP
         ENDIF
         DLAMTEST=ABS(FLOAT(ISEC2(9))/1000.-DLAM*180./PI)
         IF (DLAMTEST.GT.1.E-4) THEN
            WRITE(LOUTP,1003) FLOAT(ISEC2(9))/1000.,DLAM*180./PI
            STOP
         ENDIF
         DPHITEST=ABS(FLOAT(ISEC2(10))/1000.-90./FLOAT(JG+1))
         IF (DPHITEST.GT.1.E-4) THEN
            WRITE(LOUTP,1004) FLOAT(ISEC2(10))/1000.,90./FLOAT(JG+1)
            STOP
         ENDIF
      ENDIF
C
C     Check on levels.
C
      IF (ILEVTYPE.EQ.0) THEN
         IF (ISEC1(7).NE.109) THEN
            WRITE(LOUTP,1000) ISEC1(7)
            STOP
         ENDIF
         NLEVPAR=ISEC2(12)
         IF (NLEVPAR.NE.(2*NLP)) THEN
            WRITE(LOUTP,1010) NLEVPAR/2,NLP
            STOP
         ENDIF
         IF (LETASET) THEN
            DO 200 L=1,NLP
               AETA(L)=ZSEC2(10+L)/P0
               BETA(L)=ZSEC2(10+NLP+L)
	       WRITE(LOUTP,1011) L-1,AETA(L),BETA(L)
 200        CONTINUE
         ENDIF
      ENDIF
      IF (ILEVTYPE.EQ.1) THEN
         IF ((ISEC1(7).NE.100).AND.(ISEC1(7).NE.1)) THEN
            WRITE(LOUTP,1000) ISEC1(7)
            STOP
         ENDIF
      ENDIF
C
 1000 FORMAT(/' LEVEL INDICATOR VALUE ',I3,' NOT EXPECTED.')
 1001 FORMAT(/' NLON IN DATA = ',I5,' BUT EXPECTED ',I5)
 1002 FORMAT(/' NLAT IN DATA = ',I5,' BUT EXPECTED ',I5)
 1003 FORMAT(/' LON SPACING IN DATA = ',F9.4,' BUT EXPECTED ',F9.4)
 1004 FORMAT(/' LAT SPACING IN DATA = ',F9.4,' BUT EXPECTED ',F9.4)
 1010 FORMAT(/' N HALF-LEVELS IN DATA = ',I5,' BUT EXPECTED ',I5)
 1011 FORMAT(I5,(2E16.9))
C
      RETURN
      END
C     ***************************************************************
      SUBROUTINE RDGRIB(INP,ILENB,LINFO,KDATE,KFIELD,KLEV,
     -      ISEC0,ISEC1,ISEC2,ISEC3,ISEC4,ZSEC2,ZSEC3,ZSEC4,ILEN4)
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      INTEGER JPACK
      PARAMETER(JPSEC0=2,JPSEC1=60,JPSEC2=384,JPSEC3=2,JPSEC4=42,
     -      JPZ2=12+2*NL,JPZ3=2,JPACK=280000)
C-----------------------------------------------------------------------
C     LIMITS ON GRIB PARAMETERS
C
C     NAME    MEANING
C     ----    -------
C     JPSEC0  Maximum size for ISEC0
C     JPSEC1  Maximum size for ISEC1
C     JPSEC2  Maximum size for ISEC2
C     JPSEC3  Maximum size for ISEC3
C     JPSEC4  Maximum size for ISEC4
C     JPZ2    Maximum size for ZSEC2
C     JPZ3    Maximum size for ZSEC3
C     JPACK=280000 is large enough for T213 data
C-----------------------------------------------------------------------
C
      INTEGER ILENB, KDATE, KFIELD, KLEV, INP(ILENB)
      LOGICAL LINFO
C
      INTEGER ISEC0(JPSEC0),ISEC1(JPSEC1),ISEC2(JPSEC2),
     -      ISEC3(JPSEC3),ISEC4(JPSEC4)
      REAL ZSEC2(JPZ2), ZSEC3(JPZ3), ZSEC4(ILEN4)
      INTEGER ILEN4, IERR, IWORD
      CHARACTER OPER*1
C
C     Initialise
C
      OPER='R'
      CALL GRIBEX(ISEC0,ISEC1,ISEC2,ZSEC2,ISEC3,ZSEC3,ISEC4,
     +     ZSEC4,ILEN4,INP,ILENB,IWORD,OPER,IERR)
      IF (IERR.NE.0) THEN
         WRITE(*,*) 'ERROR reading data with GRIBEX.'
         WRITE(*,*) 'Return code IERR = ',IERR
      ENDIF
      KDATE=ISEC1(10)*1000000+ISEC1(11)*10000+
     +     ISEC1(12)*100+ISEC1(13)
      KFIELD=ISEC1(6)
      KLEV=ISEC1(8)
C
C     Write GRIB information
C
      IF (LINFO) THEN
         CALL GRPRS0 (ISEC0)
         CALL GRPRS1 (ISEC0,ISEC1)
         IF (ISEC1(5).NE.0 .AND. ISEC1(5).NE.64) THEN
            CALL GRPRS2 (ISEC0,ISEC2,ZSEC2)
         ENDIF
         IF (ISEC1(5).NE.0 .AND. ISEC1(5).NE.128) THEN
            CALL GRPRS3 (ISEC0,ISEC3,ZSEC3)
         ENDIF
      ENDIF
C
      RETURN
      END
C     ****************************************************************
      SUBROUTINE GSP2GRID
C
C     Transform from spectral data (REAL arrays) to grid point
C     space. Horizontal derivatives are taken by multiplying
C     Legendre functions by appropriate factors.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)
C
      PARAMETER(IDDAG=NLWG*IGC)
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      COMMON/RESPECTR/RZ(JPFLSH,NL),RD(JPFLSH,NL),RT(JPFLSH,NL)
     :,RQ(JPFLSH,NL),RSP(JPFLSH)
C
      COMMON/COMFFT/NTWG,NRSTWG,TRIG(IDA),WORK(IDF),IFAX(10)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      COMMON/LEGAU/
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)
     :,JH,JL
C
      COMMON/LEGAUGS/
     : ALEG(JLEGP),DYLEG(JLEGP),DM2LEG(JLEGP),DYDM2LEG(JLEGP)
C     *****************************************************************
      REAL DAG(IDDAG),ZM,ZN
      EQUIVALENCE (DAG(1),UG(1))
C
C     Statement functions.
C
      REAL DD,PM,PN
      DD(PM,PN)=SQRT((PN*PN-PM*PM)/(4.*PN*PN-1.))/PN
C
C     Calculate the Legendre polynomials at current latitude.
C
      CALL JSPLEG2(ALEG,ALAT(JL),NN)
C
C     Calculate extra polynomial for
C     (1-mu^2)*d/d(mu) del^-2 P(m,n) using recurrence relation.
C
      K=1
C
C     For m=0 to m=N-1
C
      DO 10 JM=1,MM
C
C     For n=m
C
         ZM=JM-1.
         ZN=ZM
         DYDM2LEG(K)=DD(ZM,ZN+1)*ALEG(K+1)
         K=K+1
         JMP=JM+1
C
C     For n=m+1 to n=N
C
         DO 20 JN=JMP,NN+1
            ZN=JN-1.
            DYDM2LEG(K)=-DD(ZM,ZN)*ALEG(K-1)+DD(ZM,ZN+1)*ALEG(K+1)
            K=K+1
 20      CONTINUE
C
C     For n=N+1
C
         DYDM2LEG(K)=0.
         K=K+1
 10   CONTINUE
C
C     For m=n=N and m=N,n=N+1
C
      ZM=NN
      ZN=ZM
      DYDM2LEG(K)=DD(ZM,ZN+1)*ALEG(K+1)
      K=K+1
      DYDM2LEG(K)=0.
C
C     Calculate remaining two polynomials:-
C     (1-mu^2)d/d(mu) P(m,n)  and  del^-2 P(m,n).
C
      K=1
      DO 30 JM=1,MM+1
         DO 40 JN=JM,NN+2
            DM2LEG(K)=-RSQ(JN)*ALEG(K)
            DYLEG(K)=-SQ(JN)*DYDM2LEG(K)
            K=K+1
 40      CONTINUE
 30   CONTINUE
C
C     Inverse Legendre transforms, from spectral to Fourier space.
C
      CALL LTIEC
C
C     FFT from Fourier to grid point space.
C     (UG-->PMG equivalenced in DAG).
C
      NTWG=NLWG*NHEM
      CALL FFT991(DAG,WORK,TRIG,IFAX,1,MGPP,MG,NTWG,1)
C
C     Transform specific humidity.
C
      IF (LQATTR.AND.(.NOT.LGPQ)) THEN
      N1=NL*NHEM
      CALL FFT991(QG,WORK,TRIG,IFAX,1,MGPP,MG,N1,1)
      ENDIF
C
C     Convert ln(surface pressure) to non-dimensionalised
C     surface pressure.
C
      DO 900 I=1,IGC
         PLG(I)=EXP( PLG(I) )/P0
 900  CONTINUE
C
      RETURN
      END
C     **********************************************************
      SUBROUTINE JSPLEG2(PLEG,PLAT,KTRUNC)
**    Function - calculate Legendre functions for a single latitude
**          assuming a flat Triangular truncation
**    Args in -
**               PLAT    - Latitude (radians)
**               KTRUNC  - Triangular truncation
**    Args out -
**               PLEG    - Legendre functions
**                         The array must be at least
**                         (KTRUNC+1)*(KTRUNC+4)/2 words long.
**    Args for work - none
**    Com used - none
**    Com changed - none
**    Params used - none
**    Called by - OPTION3
**    Calls - none
**    Files read - none
**    Files written - none
**    Author - R Brugge, University of Reading, based on code by
**          J D Chambers, ECMWF

**    Uses a recurrence relation with explicit relations for P(m,m) and
**    P(m,m+1)
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)
C
      PARAMETER (JPTRNC=JPNNX)
      PARAMETER (JPTRP1=(JPTRNC+1)*(JPTRNC+4))
      DIMENSION PLEG(*)
      DIMENSION ZHLP1(JPTRP1),ZHLP2(JPTRP1),ZHLP3(JPTRP1)

      ITOUT1=KTRUNC+1
      ZSIN=SIN(PLAT)
      ZCOS=SQRT(1.-ZSIN*ZSIN)

**    Step 1.        M = 0, N = 0 and N = 1
      ILM=2
      PLEG(1)=1.0
      ZF1M=SQRT(3.0)
      PLEG(2)=ZF1M*ZSIN

**    Step 2.       Sum for M = 0 to T (T = truncation)
      DO 205 JM=2,ITOUT1
      ZM= JM-1
      ZHLP1(JM)=SQRT(2.*ZM+3.)
      ZHLP2(JM)=1.0/SQRT(2.*ZM)
205   CONTINUE
      ZHLP1(1)=SQRT(3.)

      DO 570 JM=1,ITOUT1
      I1M=JM-1
      ZM=I1M
      ZRE1=ZHLP1(JM)
      ZE1=1.0/ZRE1

**    Step 3.       M > 0 only
      IF (I1M.NE.0) THEN
         ZF2M=ZF1M*ZCOS*ZHLP2(JM)
         ZF1M=ZF2M*ZRE1

**    Step 4.       N = M and N = M+1
         ILM=ILM+1
         PLEG(ILM)=ZF2M
         ILM=ILM+1
         PLEG(ILM)=ZF1M*ZSIN

**       When output truncation is reached, return to calling program
         IF (JM.EQ.ITOUT1) GOTO 570
      ENDIF

**    Step 5.       Sum for N = M+2 to T+1
      IM2=I1M+2
      DO 520 JCN=IM2,ITOUT1
      ZN=JCN
      ZHLP3(JCN)=SQRT((4.*ZN*ZN-1.)/(ZN*ZN-ZM*ZM))
520   CONTINUE

      DO 560 JCN=IM2,ITOUT1
      ZE2=ZHLP3(JCN)
      ILM=ILM+1
      PLEG(ILM)=ZE2*(ZSIN*PLEG(ILM-1)-ZE1*PLEG(ILM-2))
      ZE2=1./ZE2
      ZE1=ZE2
560   CONTINUE

570   CONTINUE
C
      RETURN
      END
C     ***********************************************************
      SUBROUTINE LTIEC
C
C     Inverse Legendre transforms from spectral to Fourier space.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      COMMON/RESPECTR/RZ(JPFLSH,NL),RD(JPFLSH,NL),RT(JPFLSH,NL)
     :,RQ(JPFLSH,NL),RSP(JPFLSH)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      COMMON/POLYNO/POLYF(NWJ2,NHEM),CMPA(IGL)
      COMPLEX CMPA
C
      COMPLEX CUG(IGK),CVG(IGK),CSFG(IGK)
     :,CTG(IGK),CPMG(IGL),CPLG(IGL)
     :,CSDOTG(IGK),CTXG(IGK)
      EQUIVALENCE (CUG(1),UG(1)),(CVG(1),VG(1)),(CSFG(1),THG(1))
     :,(CSDOTG(1),SDOTG(1)),(CTG(1),TG(1)),(CTXG(1),TXG(1))
     :,(CPMG(1),PMG(1)),(CPLG(1),PLG(1))
C
C     Wind components.  Calls to HEXPEC give following Fourier fields:
C        UG   :   -U(rot).
C        VG   :   V(div).
C        THG  :   streamfunction.      (Temporary - overwritten below)
C        SDOTG:   velocity-potential.             " "
C     Then sum to give total winds.  CMPA takes x-derivative.
C
      CALL HEXPEC(RZ,UG,NL,4)
      CALL HEXPEC(RZ,THG,NL,3)
      CALL HEXPEC(RD,SDOTG,NL,3)
      CALL HEXPEC(RD,VG,NL,4)
      II=0
      DO 20 L=1,NL
         DO 22 I=1,IGL
            II=II+1
            CUG(II)=CSDOTG(II)*CMPA(I)-CUG(II)
            CVG(II)=CSFG(II)*CMPA(I)+CVG(II)
 22      CONTINUE
 20   CONTINUE
C
C     Fields used to obtain vertical velocity.
C
      CALL HEXPEC(RD,DG,NL,1)
      CALL HEXPEC(RSP,PLG,1,1)
      CALL HEXPEC(RSP,PJG,1,2)
      DO 35 I=1,IGL
         CPMG(I)=CPLG(I)*CMPA(I)
 35   CONTINUE
C
C     Temperature, humidity and fields for PV calculation.
C
      IF (LTATTR) CALL HEXPEC(RT,TG,NL,1)
      IF (LQATTR.AND.(.NOT.LGPQ)) CALL HEXPEC(RQ,QG,NL,1)
      IF (LPVATTR) THEN
         CALL HEXPEC(RT,TYG,NL,2)
         II=0
         DO 36 L=1,NL
            DO 37 I=1,IGL
               II=II+1
               CTXG(II)=CTG(II)*CMPA(I)
 37         CONTINUE
 36      CONTINUE
C
C     Add planetary vorticity to give absolute vorticity.
C
         DO 40 L=1,NL
            RZ(3,L)=RZ(3,L)+EZR
 40      CONTINUE
         CALL HEXPEC(RZ,ZG,NL,1)
         DO 42 L=1,NL
            RZ(3,L)=RZ(3,L)-EZR
 42      CONTINUE
      ENDIF
C
      RETURN
      END
C     **********************************************************
      SUBROUTINE HEXPEC(SV,GV,NLS,ITYPE)
C
C     Performs indirect Legendre transform for a (set of) field(s)
C     having a total of NLS levels, from spectral to Fourier space.
C     The type of function and thence of transform is chosen by ITYPE
C     with the following currently defined:
C        ITYPE=1   :   ALEG     :   normal transform.
C        ITYPE=2   :   DYLEG    :   y-derivative.
C        ITYPE=3   :   DM2LEG   :   del(-2).
C        ITYPE=4   :   DYDM2LEG :   y-derivative of del(-2).
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
      COMMON/LEGAUGS/
     : ALEG(JLEGP),DYLEG(JLEGP),DM2LEG(JLEGP),DYDM2LEG(JLEGP)
C     *****************************************************************
      DIMENSION SV(JPFLSH,NLS),ZSEC4(JPFLSH)
      DIMENSION GV(IGC,NLS),ZFA(MGPP,2),PLEG(JLEGP)
      INTEGER ISYM
C
      IF (ITYPE.EQ.1) THEN
         ISYM=1
         DO 10 I=1,JLEGP
            PLEG(I)=ALEG(I)
 10      CONTINUE
      ENDIF
      IF (ITYPE.EQ.2) THEN
         ISYM=-1
         DO 12 I=1,JLEGP
            PLEG(I)=DYLEG(I)
 12      CONTINUE
      ENDIF
      IF (ITYPE.EQ.3) THEN
         ISYM=1
         DO 14 I=1,JLEGP
            PLEG(I)=DM2LEG(I)
 14      CONTINUE
      ENDIF
      IF (ITYPE.EQ.4) THEN
         ISYM=-1
         DO 16 I=1,JLEGP
            PLEG(I)=DYDM2LEG(I)
 16      CONTINUE
      ENDIF
C
      IGROUP=1
      I2=2*IGROUP
      DO 100 L=1,NLS
         DO 110 I=1,JPFLSH
            ZSEC4(I)=SV(I,L)
 110     CONTINUE
         CALL JSYMGG(ZSEC4,PLEG,ISYM,ZFA)
         II=0
         DO 120 IHEM=1,I2
            DO 122 I=1,MGPP
               II=II+1
               GV(II,L)=ZFA(I,IHEM)
 122        CONTINUE
 120     CONTINUE
 100  CONTINUE
C
      RETURN
      END
C     ***************************************************************
      SUBROUTINE JSYMGG(PSHUP,PLEG,ISYM,PZFA)
**    Function - calculate gridpoint data
**    Args in -
**               PSHUP   - Spherical harmonics field, unpacked
**    Args out -
**               PZFA    - Output grid point field; contains
**                         North and South latitude rows
**                         symmetrically.
**    Args for work -
**               PLEG    - Array used to hold Legendre function
**               ISYM    - Symmetry of Legendre function
**    Com used - none
**    Com changed - none
**    Params used - none
**    Called by - OPTION3
**    Calls - CSUM
**    Files read - none
**    Files written - none
**    Author - R Brugge, University of Reading, based on code by
**          J D Chambers, ECMWF
C
C     Heavily modified for 'offline' by J Methven, Reading.
C     Only does calculation for one latitude pair.
C     Only the wave to Fourier space transforms are performed here,
C     not the FFT's from Fourier space to grid.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)
C
      COMPLEX PSHUP
      DIMENSION PSHUP(JPNECS)
      REAL PLEG(JLEGP),PZFA(MGPP,2)
C
      INTEGER ILIM,IMLIM
      INTEGER ITAL,ITALA,ITALS,IMN,IMP
      INTEGER ISYM,INORTH,ISOUTH
      INTEGER JM,J242,JF
C
      COMPLEX ZDUM(NN+1)
      COMPLEX ZSUMS(NN+1),ZSUMA(NN+1)
C
      EXTERNAL CSUM
      COMPLEX  CSUM
C
      ILIM=NN+1
      IMLIM=MM+1
      INORTH=1
      ISOUTH=2
C
C     Clear unused elements in array.
C
      DO 241 JF=2*IMLIM+1,MGPP
         PZFA(JF,INORTH)=0.0
         PZFA(JF,ISOUTH)=0.0
 241  CONTINUE
C
C     The north and corresponding south latitude row are
C     calculated at the same time from the same entry in the
C     legendre function file.
C
      IMN = 0
      IMP = 0
      DO 244 JM=1,IMLIM
         ITAL=ILIM-JM+1
         DO 242 J242=1,ITAL
            ZDUM(J242)=PLEG(IMP+J242)*PSHUP(IMN+J242)
 242     CONTINUE
         IMP=IMP+ITAL+1
         IMN=IMN+ITAL
         ITALS=(ITAL+1)/2
         ITALA=ITAL/2
         ZSUMS(JM)=CSUM(ITALS,ZDUM,2)
         ZSUMA(JM)=CSUM(ITALA,ZDUM(2),2)
 244  CONTINUE

**    For the southern hemisphere row, the legendre functions are
**    the complex conjugates of the corresponding northern row -
**    hence the juggling with the signs in the next loop.

**    Note that PZFA is REAL, but the coefficients being calculated
**    are COMPLEX.  There are pairs of values for each coefficient
**    (real and imaginary parts) and pairs of values for each
**    latitude (north and south).

      DO 246 JM=1,IMLIM
         PZFA(2*JM-1,INORTH)=REAL(ZSUMS(JM))+REAL(ZSUMA(JM))
         PZFA(2*JM,INORTH)=AIMAG(ZSUMS(JM))+AIMAG(ZSUMA(JM))
         PZFA(2*JM-1,ISOUTH)=ISYM*(REAL(ZSUMS(JM))-REAL(ZSUMA(JM)))
         PZFA(2*JM,ISOUTH)=ISYM*(AIMAG(ZSUMS(JM))-AIMAG(ZSUMA(JM)))
 246  CONTINUE
C
      RETURN
      END
C     ***********************************************************
      COMPLEX FUNCTION CSUM(KN,UVEC,KNCX)
**    Function - replacement for BLAS routine CSUM - compute the
**          complex sum of a complex vector
**    Args in -
**               KN      - Number of elements in vector
**               UVEC    - Complex vector to be summed
**               KNCX    - Skip distance between elementx in UVEC
**    Args out -
**               CSUM    - Complex sum
**    Args for work - none
**    Com used - none
**    Com changed - none
**    Params used - none
**    Called by - JSYMGG
**    Calls - none
**    Files read - none
**    Files written - none
**    Author - R Brugge, University of Reading

      INTEGER KN, KNCX
      COMPLEX UVEC (*)
C     COMPLEX UVEC (214)
      INTEGER IP
      COMPLEX CHOLD

      CHOLD = (0.0, 0.0)

      DO 110 IP=0,KN -1
      CHOLD=CHOLD+UVEC(1+IP*KNCX)
110   CONTINUE

      CSUM = CHOLD

      RETURN
      END
C
C     ***************************************************************
      SUBROUTINE READEC
C
C     Read regularly gridded lat-lon data from GRIB files.
C     The data is expected to be on pressure levels.
C
C     Adapted from R.Brugge's Package X.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)
C
      INTEGER JPACK
      PARAMETER(JPSEC0=2,JPSEC1=60,JPSEC2=384,JPSEC3=2,JPSEC4=42,
     -      JPZ2=12+2*NL,JPZ3=2,JPACK=280000)
C-----------------------------------------------------------------------
C     LIMITS ON GRIB PARAMETERS
C
C     NAME    MEANING
C     ----    -------
C     JPSEC0  Maximum size for ISEC0
C     JPSEC1  Maximum size for ISEC1
C     JPSEC2  Maximum size for ISEC2
C     JPSEC3  Maximum size for ISEC3
C     JPSEC4  Maximum size for ISEC4
C     JPZ2    Maximum size for ZSEC2
C     JPZ3    Maximum size for ZSEC3
C     JPACK=280000 is large enough for T213 data
C-----------------------------------------------------------------------
C
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)
C      PARAMETER(IGDLAP=1,IGCP=IGC)
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      COMMON/LEGAU/
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)
     :,JH,JL
C
C
      PARAMETER(JLATS=2*(JG+1)+1,ILEN4=MG*JLATS)
      INTEGER IREC,IREM,INPFEND,IFIELD,KLEV,ISTAT
      DIMENSION ZSEC4(ILEN4)
      DIMENSION ZGR(MG,JLATS,NL),TGR(MG,JLATS,NL),UGR(MG,JLATS,NL)
     :   ,VGR(MG,JLATS,NL),OMGR(MG,JLATS,NL),QGR(MG,JLATS,NL)
C
C     Determine channel for required GRIB spectral file.
C     Find filename for channel.
C
      IREC=NINT((DAY-BEGDAY)/THIST)
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)
      INPFEND=IOFFSET+7
      IF (ISYY.GT.99) INPFEND=IOFFSET+9
      IF (IREM.EQ.0) THEN
         CALL MAKENAME(FSTEM,IOFFSET,INPFNAME,NCDATE,LGPQ)
         WRITE(INPFNAME(INPFEND+1:INPFEND+4),'(A4)') '.grb'
         INPFEND=INPFEND+4
         WRITE(LOUTP,*) 'Assuming file ',INPFNAME(1:INPFEND)
     :        ,' is Cray unblocked'
         ISTAT=0
C
C     Note that PBOPEN will change the channel number INPUT.
C
         CALL PBOPEN(INPUT,INPFNAME(1:INPFEND),'r',ISTAT)
         IF(ISTAT.NE.0) THEN
            WRITE(LOUTP,*) 'Error opening file ',INPFNAME(1:INPFEND)
            WRITE(LOUTP,*) 'PBOPEN returns ISTAT = ',ISTAT
            WRITE(LOUTP,*) 'Called from READEC'
            CALL ABORT
         ELSE
            PRINT *,INPFNAME(1:INPFEND),' OPENED'
         ENDIF
      ENDIF
C
C     Loop over variables Z,T,U,V,Q,W for all levels.
C     NOTE: these records contain relative humidity.
C
      DO 285 L=1,NL
         DO 290 IVAR=1,6
            IFIELD=0
            CALL SPUNPACK(ZSEC4,ILEN4,INPUT,IFIELD,KLEV)
            IF (IFIELD.EQ.129) THEN
               II=0
               DO 200 J=1,JLATS
                  DO 205 I=1,MG
                     II=II+1
                     ZGR(I,J,L)=ZSEC4(II)
 205              CONTINUE
 200           CONTINUE
            ENDIF
            IF (IFIELD.EQ.130) THEN
               II=0
               DO 210 J=1,JLATS
                  DO 215 I=1,MG
                     II=II+1
                     TGR(I,J,L)=ZSEC4(II)
 215              CONTINUE
 210           CONTINUE
            ENDIF
            IF (IFIELD.EQ.131) THEN
               II=0
               DO 220 J=1,JLATS
                  DO 225 I=1,MG
                     II=II+1
                     UGR(I,J,L)=ZSEC4(II)
 225              CONTINUE
 220           CONTINUE
            ENDIF
            IF (IFIELD.EQ.132) THEN
               II=0
               DO 230 J=1,JLATS
                  DO 235 I=1,MG
                     II=II+1
                     VGR(I,J,L)=ZSEC4(II)
 235              CONTINUE
 230           CONTINUE
            ENDIF
            IF (IFIELD.EQ.157) THEN
               II=0
               DO 240 J=1,JLATS
                  DO 245 I=1,MG
                     II=II+1
                     QGR(I,J,L)=ZSEC4(II)
 245              CONTINUE
 240           CONTINUE
            ENDIF
            IF (IFIELD.EQ.135) THEN
               II=0
               DO 250 J=1,JLATS
                  DO 255 I=1,MG
                     II=II+1
                     OMGR(I,J,L)=ZSEC4(II)
 255              CONTINUE
 250           CONTINUE
            ENDIF
 290     CONTINUE
 285  CONTINUE
C
C     Close input file.
C
      IF (IREM.EQ.0) THEN
         ISTAT=0
         CALL PBCLOSE(INPUT,ISTAT)
         IF(ISTAT.NE.0) THEN
            WRITE(LOUTP,*) 'ERROR CLOSING FILE ',INPFNAME(1:INPFEND)
            WRITE(LOUTP,*) 'ISTAT = ',ISTAT
            CALL ABORT
         ENDIF
      ENDIF
C
C     Loop over latitude for grid point calculations and
C     writing to attribute files.
C
      INORTH=0
      ISOUTH=MGPP
      JL=1
      DO 1000 J=1,JG
C
C     Miss out grid points at poles and equator.
C     PSGLA contains geopotential height for testing whether
C     below ground or not.
C
         KK=(JL-1)*IGD
         JSOUTH=JGGP-J
         DO 305 L=1,NL
            LL=(L-1)*IGC
            DO 310 I=1,MG
               URHS(KK+LL+INORTH+I)=UGR(I,J+1,L)
     :              *86400./(RADEA*CS(J))
               URHS(KK+LL+ISOUTH+I)=UGR(I,JSOUTH+2,L)
     :              *86400./(RADEA*CS(JSOUTH))
               VRHS(KK+LL+INORTH+I)=VGR(I,J+1,L)
     :              *86400./RADEA
               VRHS(KK+LL+ISOUTH+I)=VGR(I,JSOUTH+2,L)
     :              *86400./RADEA
               SDRHS(KK+LL+INORTH+I)=OMGR(I,J+1,L)
     :              *86400./P0
               SDRHS(KK+LL+ISOUTH+I)=OMGR(I,JSOUTH+2,L)
     :              *86400./P0
               PSGLA(KK+LL+INORTH+I)=ZGR(I,J+1,L)
               PSGLA(KK+LL+ISOUTH+I)=ZGR(I,JSOUTH+2,L)
               THGLA(KK+LL+INORTH+I)=TGR(I,J+1,L)
               THGLA(KK+LL+ISOUTH+I)=TGR(I,JSOUTH+2,L)
               QG(LL+INORTH+I)=QGR(I,J+1,L)
               QG(LL+ISOUTH+I)=QGR(I,JSOUTH+2,L)
 310        CONTINUE
 305     CONTINUE
C
C     Write attribute files.
C
         DO 430 L=1,NL
            LL=(L-1)*IGC
            DO 435 I=1,IGC
               TG(LL+I)=THGLA(KK+LL+I)
               THGLA(KK+LL+I)=THGLA(KK+LL+I)*(ALEV(L)**(-AKAP))
               THG(LL+I)=THGLA(KK+LL+I)
 435        CONTINUE
 430     CONTINUE
         IF (NATTR.GT.0) THEN
            WRITE(NCGP(1)) TG
            WRITE(NCGP(2)) THG
            WRITE(NCGP(4)) QG
         ENDIF
C
         JL=JL+1
 1000 CONTINUE
C
      RETURN
      END
C     ***************************************************************
      SUBROUTINE READOROG
C
C     Read regularly gridded lat-lon OROGRAPHY from GRIB files
C     and place in PLGLA array.
C
C
C     Do NOT set NTRAC=0 since some arrays will then have zero length.
C     If history file has no tracers use NTRAC=1 and LTRACSWITCH=.F. .
C
      PARAMETER(NN=159,MM=159,NHEM=2,NL=60,MOCT=1,MG=320,JG=80
     P  ,NWJ2=2,NCRAY=64,NTRAC=1,NPART=300,IPTS=9
     P  ,NATTR=3,MAXCLUS=100)
C
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI,PI2DM=PI2/MOCT
     :,JGG=JG*NHEM,JGGP=JGG+1,MJP=2*NWJ2,JLEGP=(NN+1)*(NN+4)/2
     :,NLM=NL-1,NLP=NL+1,NL2=NL*NL,NNP=NN+1,NWW=1+(MM-1)/MOCT
     :,MGPP=MG+2,IGC=MGPP*NHEM,IGD=IGC*NL,IGDLA=IGD*JG
     :,IGDT=IGD*NTRAC,IDL=MGPP/2,IGL=IDL*NHEM,IGK=IGL*NL
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGBT=IGB*NTRAC
     :,IDA=3*MG/2+1,IDF=NCRAY*(MG+1),NLWG=7*NL+3,NLTR=NL*NTRAC
     :,NFPPAR=NATTR+3,MAXATTR=NATTR+8)
C
      PARAMETER(JPJGX=JG,JPJGGX=NHEM*JG,JPMGX=MG,JPNNX=NN,JPMMX=MM
     :,JPNECS=((NN+1)*(NN+2))/2,JPFLSH=2*JPNECS)
C
      INTEGER JPACK
      PARAMETER(JPSEC0=2,JPSEC1=60,JPSEC2=384,JPSEC3=2,JPSEC4=42,
     -      JPZ2=12+2*NL,JPZ3=2,JPACK=280000)
C-----------------------------------------------------------------------
C     LIMITS ON GRIB PARAMETERS
C
C     NAME    MEANING
C     ----    -------
C     JPSEC0  Maximum size for ISEC0
C     JPSEC1  Maximum size for ISEC1
C     JPSEC2  Maximum size for ISEC2
C     JPSEC3  Maximum size for ISEC3
C     JPSEC4  Maximum size for ISEC4
C     JPZ2    Maximum size for ZSEC2
C     JPZ3    Maximum size for ZSEC3
C     JPACK=280000 is large enough for T213 data
C-----------------------------------------------------------------------
C
      PARAMETER(IGDLAP=IGDLA,IGCP=IGC)
C      PARAMETER(IGDLAP=1,IGCP=IGC)
      COMMON/COMPSG/PSGLA(IGDLAP),PSGLAM(IGDLAP),PLGLAM(IGCP,JG)
C
      COMMON/CHANS/RNTAPE,LOUTP,NCBIN,NCEC,INPUT,INPUT2
     :,NCINTRAJ,NCGP(MAXATTR)
     :,LPOUT,LEVERY,IWORDSIZE,IOFFSET,IOFFOUT
     :,FSTEM,FSTEM2,FSTEMO,INPFNAME
      LOGICAL LPOUT,LEVERY
      CHARACTER*80 FSTEM,FSTEM2,FSTEMO,INPFNAME
C
      COMMON/TIMEV/DAY,BEGDAY,THIST,TRELEASE,TINTEG,RECINT,TSPD
     :,ISYY,ISMM,ISDD,ISHH,NRECPFILE,IDATADATE
     :,LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,H1,NSTEPS,NHISTS,NJUMP,NSKIP
     :,POSN(IPTS,NPART,NFPPAR),VPOSN(IPTS,NPART)
     :,IATTRTYP(MAXATTR),NCHI(2),NSETS,NPSET
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
      LOGICAL LTRACSWITCH,LDRY,LT3D,LFORW,LMULTI,LFORECAST
     :,LSPECTRAL,LERA,LQATTR,LTATTR,LPVATTR
C
      COMMON/BLANK/ SQ(NN+2),RSQ(NN+2),SIGMAH(NLM),SIGMA(NL)
     :,T0(NL),DSIGMA(NL),DLAM,JSAV,LSAV,LHSAV
     :,ZUBZX,ZTBZX,LUGRID(MAXATTR)
     :,AETA(NL+1),BETA(NL+1),DBETA(NL),CETA(NL)
     :,RGG(NL2),ALEV(NL),ALEVH(NL+1),ALAT(JGG),ALATT(JGG)
     :,GA,WW,RADEA,P0,EZ,EZR,AKAP,RDGAS
     :,CV,CT,CQ,CERT,KOLOUR(NTRAC),CTRA(NTRAC)
     :,MF,MFP,NF,NFP,MFPP,NFPP
     :,IUVFORMAT,IGRIDTYPE,ILEVTYPE,LEVZT1,LOROG,LGPQ
      COMPLEX EZ
      LOGICAL LUGRID,LEVZT1,LOROG,LGPQ
C
C
C     UG->PMG equivalenced in the subroutines
C     GSP2GRID and RSP2GRID. Do NOT change their order.
C
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),TG(IGD)
     :,TXG(IGD),TYG(IGD),PLG(IGC),PJG(IGC),PMG(IGC)
     :,TRAG(IGDT),SDOTG(IGD)
     :,PSGH(IGC,NL+1),PSG(IGC,NL),THG(IGD),QG(IGD),EPVG(IGD)
     :,URHS(IGDLA),VRHS(IGDLA),SDRHS(IGDLA)
     :,UM(IGDLA),VM(IGDLA),SDM(IGDLA)
     :,THGLA(IGDLA),PLGLA(IGC,JG)
C
      COMMON/LEGAU/
     : SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)
     :,JH,JL
C
C
      PARAMETER(JLATS=2*(JG+1)+1,ILEN4=MG*JLATS)
      INTEGER IREC,IREM,INPFEND,IFIELD,KLEV,ISTAT
      DIMENSION ZSEC4(ILEN4)
      DIMENSION OROG(MG,JLATS)
C
C     Determine channel for required GRIB spectral file.
C     Find filename for channel.
C
      IREC=NINT((DAY-BEGDAY)/THIST)
      IREM=IREC-NRECPFILE*(IREC/NRECPFILE)
      INPFEND=IOFFSET+7
      IF (ISYY.GT.99) INPFEND=IOFFSET+9
      IF (IREM.EQ.0) THEN
         CALL MAKENAME(FSTEM2,IOFFSET,INPFNAME,NCDATE,LGPQ)
         WRITE(INPFNAME(INPFEND+1:INPFEND+4),'(A4)') '.grb'
         INPFEND=INPFEND+4
         WRITE(LOUTP,*) 'Assuming file ',INPFNAME(1:INPFEND)
     :        ,' is Cray unblocked'
         ISTAT=0
C
C     Note that PBOPEN will change the channel number INPUT.
C
         CALL PBOPEN(INPUT2,INPFNAME(1:INPFEND),'r',ISTAT)
         IF(ISTAT.NE.0) THEN
            WRITE(LOUTP,*) 'Error opening file ',INPFNAME(1:INPFEND)
            WRITE(LOUTP,*) 'PBOPEN returns ISTAT = ',ISTAT
            WRITE(LOUTP,*) 'Called from READOROG'
            CALL ABORT
         ELSE
            PRINT *,INPFNAME(1:INPFEND),' OPENED'
         ENDIF
      ENDIF
C
C     Read orographic height.
C
      IFIELD=0
      CALL SPUNPACK(ZSEC4,ILEN4,INPUT2,IFIELD,KLEV)
      IF (IFIELD.EQ.129) THEN
         II=0
         DO 200 J=1,JLATS
            DO 205 I=1,MG
               II=II+1
               OROG(I,J)=ZSEC4(II)
 205        CONTINUE
 200     CONTINUE
      ELSE
         WRITE(LOUTP,*) 'First field was not orographic height.'
         STOP
      ENDIF
C
C     Close input file.
C
      IF (IREM.EQ.0) THEN
         ISTAT=0
         CALL PBCLOSE(INPUT2,ISTAT)
         IF(ISTAT.NE.0) THEN
            WRITE(LOUTP,*) 'ERROR CLOSING FILE ',INPFNAME(1:INPFEND)
            WRITE(LOUTP,*) 'ISTAT = ',ISTAT
            CALL ABORT
         ENDIF
      ENDIF
C
C     Loop over latitude for grid point calculations and
C     writing to attribute files.
C
      INORTH=0
      ISOUTH=MGPP
      DO 1000 J=1,JG
C
C     Miss out grid points at poles and equator.
C     PLGLA contains OROGRAPHIC height for testing whether
C     below ground or not.
C
         JSOUTH=JGGP-J
         DO 310 I=1,MG
            PLGLA(INORTH+I,J)=OROG(I,J+1)
            PLGLA(ISOUTH+I,J)=OROG(I,JSOUTH+2)
 310     CONTINUE
 1000 CONTINUE
C
      RETURN
      END
C     ***************************************************************
C     SUBROUTINE 'SET99' - COMPUTES FACTORS OF N & TRIGONOMETRIC
C     FUNCTINS REQUIRED BY FFT991(F)
C
      SUBROUTINE SET99(TRIGS,IFAX,N)
      DIMENSION TRIGS(N),IFAX(1),JFAX(10),LFAX(7)
      DATA LFAX/6,8,5,4,3,2,1/
C
      DEL=4.0*ASIN(1.0)/FLOAT(N)
      NIL=0
      NHL=(N/2)-1
      DO 10 K=NIL,NHL
      ANGLE=FLOAT(K)*DEL
      TRIGS(2*K+1)=COS(ANGLE)
      TRIGS(2*K+2)=SIN(ANGLE)
   10 CONTINUE
C
C     FIND FACTORS OF N (8,6,5,4,3,2; ONLY ONE 8 ALLOWED)
C     LOOK FOR SIXES FIRST, STORE FACTORS IN DESCENDING ORDER
      NU=N
      IFAC=6
      K=0
      L=1
   20 CONTINUE
      IF (MOD(NU,IFAC).NE.0) GO TO 30
      K=K+1
      JFAX(K)=IFAC
      IF (IFAC.NE.8) GO TO 25
      IF (K.EQ.1) GO TO 25
      JFAX(1)=8
      JFAX(K)=6
   25 CONTINUE
      NU=NU/IFAC
      IF (NU.EQ.1) GO TO 50
      IF (IFAC.NE.8) GO TO 20
   30 CONTINUE
      L=L+1
      IFAC=LFAX(L)
      IF (IFAC.GT.1) GO TO 20
C
      WRITE(6,40) N
   40 FORMAT(4H1N =,I4,27H - CONTAINS ILLEGAL FACTORS)
      RETURN
C
C     NOW REVERSE ORDER OF FACTORS
   50 CONTINUE
      NFAX=K
      IFAX(1)=NFAX
      DO 60 I=1,NFAX
      IFAX(NFAX+2-I)=JFAX(I)
   60 CONTINUE
      RETURN
      END
C     ***************************************************************
C     SUBROUTINE 'FFT991' - MULTIPLE FAST REAL PERIODIC TRANSFORM
C
C     Minor modifications - Clive Temperton, January 1991:
C         modified vector-chopping for better performance
C
C     REAL TRANSFORM OF LENGTH N PERFORMED BY REMOVING REDUNDANT
C     OPERATIONS FROM COMPLEX TRANSFORM OF LENGTH N
C
C     A IS THE ARRAY CONTAINING INPUT & OUTPUT DATA
C     WORK IS AN AREA OF SIZE (N+1)*MIN(LOT,64)
C     TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES
C     IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N
C     INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR'
C         (E.G. INC=1 FOR CONSECUTIVELY STORED DATA)
C     JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR
C     N IS THE LENGTH OF THE DATA VECTORS
C     LOT IS THE NUMBER OF DATA VECTORS
C     ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT
C           = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL
C
C     ORDERING OF COEFFICIENTS:
C         A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2)
C         WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED
C
C     ORDERING OF DATA:
C         X(0),X(1),X(2),...,X(N-1), 0 , 0 ; (N+2) LOCATIONS REQUIRED
C
C     VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS
C     IN PARALLEL
C
C     N MUST BE COMPOSED OF FACTORS 2,3 & 5 BUT DOES NOT HAVE TO BE EVEN
C
C     DEFINITION OF TRANSFORMS:
C     -------------------------
C
C     ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N))
C         WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K)
C
C     ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N))
C               B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N))
C
      SUBROUTINE FFT991(A,WORK,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN)
      DIMENSION A(N),WORK(N),TRIGS(N),IFAX(1)
C
      NFAX=IFAX(1)
      NX=N+1
      IF (MOD(N,2).EQ.1) NX=N
      NBLOX=1+(LOT-1)/64
      LEFT=LOT
      IF (ISIGN.EQ.-1) GO TO 300
C
C     ISIGN=+1, SPECTRAL TO GRIDPOINT TRANSFORM
C     -----------------------------------------
  100 CONTINUE
      ISTART=1
      DO 220 NB=1,NBLOX
      IF (LEFT.LE.64) THEN
         NVEX=LEFT
      ELSE IF (LEFT.LT.128) THEN
         NVEX=LEFT/2
      ELSE
         NVEX=64
      ENDIF
      LEFT=LEFT-NVEX
      IA=ISTART
      I=ISTART
CDIR$ IVDEP
      DO 110 J=1,NVEX
      A(I+INC)=0.5*A(I)
      I=I+JUMP
  110 CONTINUE
      IF (MOD(N,2).EQ.1) GO TO 130
      I=ISTART+N*INC
      DO 120 J=1,NVEX
      A(I)=0.5*A(I)
      I=I+JUMP
  120 CONTINUE
  130 CONTINUE
      IA=ISTART+INC
      LA=1
      IGO=+1
C
      DO 160 K=1,NFAX
      IFAC=IFAX(K+1)
      IERR=-1
      IF (IGO.EQ.-1) GO TO 140
      CALL RPASSM(A(IA),A(IA+LA*INC),WORK(1),WORK(IFAC*LA+1),TRIGS,
     *    INC,1,JUMP,NX,NVEX,N,IFAC,LA,IERR)
      GO TO 150
  140 CONTINUE
      CALL RPASSM(WORK(1),WORK(LA+1),A(IA),A(IA+IFAC*LA*INC),TRIGS,
     *    1,INC,NX,JUMP,NVEX,N,IFAC,LA,IERR)
  150 CONTINUE
      IF (IERR.NE.0) GO TO 500
      LA=IFAC*LA
      IGO=-IGO
      IA=ISTART
  160 CONTINUE
C
C     IF NECESSARY, COPY RESULTS BACK TO A
C     ------------------------------------
      IF (MOD(NFAX,2).EQ.0) GO TO 190
      IBASE=1
      JBASE=IA
      DO 180 JJ=1,NVEX
      I=IBASE
      J=JBASE
      DO 170 II=1,N
      A(J)=WORK(I)
      I=I+1
      J=J+INC
  170 CONTINUE
      IBASE=IBASE+NX
      JBASE=JBASE+JUMP
  180 CONTINUE
  190 CONTINUE
C
C     FILL IN ZEROS AT END
C     --------------------
      IX=ISTART+N*INC
CDIR$ IVDEP
      DO 210 J=1,NVEX
      A(IX)=0.0
      A(IX+INC)=0.0
      IX=IX+JUMP
  210 CONTINUE
C
      ISTART=ISTART+NVEX*JUMP
  220 CONTINUE
      RETURN
C
C     ISIGN=-1, GRIDPOINT TO SPECTRAL TRANSFORM
C     -----------------------------------------
  300 CONTINUE
      ISTART=1
      DO 410 NB=1,NBLOX
      IF (LEFT.LE.64) THEN
         NVEX=LEFT
      ELSE IF (LEFT.LT.128) THEN
         NVEX=LEFT/2
      ELSE
         NVEX=64
      ENDIF
      LEFT=LEFT-NVEX
      IA=ISTART
      LA=N
      IGO=+1
C
      DO 340 K=1,NFAX
      IFAC=IFAX(NFAX+2-K)
      LA=LA/IFAC
      IERR=-1
      IF (IGO.EQ.-1) GO TO 320
      CALL QPASSM(A(IA),A(IA+IFAC*LA*INC),WORK(1),WORK(LA+1),TRIGS,
     *    INC,1,JUMP,NX,NVEX,N,IFAC,LA,IERR)
      GO TO 330
  320 CONTINUE
      CALL QPASSM(WORK(1),WORK(IFAC*LA+1),A(IA),A(IA+LA*INC),TRIGS,
     *    1,INC,NX,JUMP,NVEX,N,IFAC,LA,IERR)
  330 CONTINUE
      IF (IERR.NE.0) GO TO 500
      IGO=-IGO
      IA=ISTART+INC
  340 CONTINUE
C
C     IF NECESSARY, COPY RESULTS BACK TO A
C     ------------------------------------
      IF (MOD(NFAX,2).EQ.0) GO TO 370
      IBASE=1
      JBASE=IA
      DO 360 JJ=1,NVEX
      I=IBASE
      J=JBASE
      DO 350 II=1,N
      A(J)=WORK(I)
      I=I+1
      J=J+INC
  350 CONTINUE
      IBASE=IBASE+NX
      JBASE=JBASE+JUMP
  360 CONTINUE
  370 CONTINUE
C
C     SHIFT A(0) & FILL IN ZERO IMAG PARTS
C     ------------------------------------
      IX=ISTART
CDIR$ IVDEP
      DO 380 J=1,NVEX
      A(IX)=A(IX+INC)
      A(IX+INC)=0.0
      IX=IX+JUMP
  380 CONTINUE
      IF (MOD(N,2).EQ.1) GO TO 400
      IZ=ISTART+(N+1)*INC
      DO 390 J=1,NVEX
      A(IZ)=0.0
      IZ=IZ+JUMP
  390 CONTINUE
  400 CONTINUE
C
      ISTART=ISTART+NVEX*JUMP
  410 CONTINUE
      RETURN
C
C     ERROR MESSAGES
C     --------------
  500 CONTINUE
      GO TO (510,530,550) IERR
  510 CONTINUE
      WRITE(6,520) NVEX
  520 FORMAT(16H1VECTOR LENGTH =,I4,17H, GREATER THAN 64)
      GO TO 570
  530 CONTINUE
      WRITE(6,540) IFAC
  540 FORMAT( 9H1FACTOR =,I3,17H, NOT CATERED FOR)
      GO TO 570
  550 CONTINUE
      WRITE(6,560) IFAC
  560 FORMAT(9H1FACTOR =,I3,31H, ONLY CATERED FOR IF LA*IFAC=N)
  570 CONTINUE
      RETURN
      END
C     ***************************************************************
C     SUBROUTINE 'RPASSM' - PERFORMS ONE PASS THROUGH DATA AS PART
C     OF MULTIPLE REAL FFT (FOURIER SYNTHESIS) ROUTINE
C
C     A IS FIRST REAL INPUT VECTOR
C         EQUIVALENCE B(1) WITH A (LA*INC1+1)
C     C IS FIRST REAL OUTPUT VECTOR
C         EQUIVALENCE D(1) WITH C(IFAC*LA*INC2+1)
C     TRIGS IS A PRECALCULATED LIST OF SINES & COSINES
C     INC1 IS THE ADDRESSING INCREMENT FOR A
C     INC2 IS THE ADDRESSING INCREMENT FOR C
C     INC3 IS THE INCREMENT BETWEEN INPUT VECTORS A
C     INC4 IS THE INCREMENT BETWEEN OUTPUT VECTORS C
C     LOT IS THE NUMBER OF VECTORS
C     N IS THE LENGTH OF THE VECTORS
C     IFAC IS THE CURRENT FACTOR OF N
C     LA IS THE PRODUCT OF PREVIOUS FACTORS
C     IERR IS AN ERROR INDICATOR:
C              0 - PASS COMPLETED WITHOUT ERROR
C              1 - LOT GREATER THAN 64
C              2 - IFAC NOT CATERED FOR
C              3 - IFAC ONLY CATERED FOR IF LA=N/IFAC
C
C-----------------------------------------------------------------------
C
      SUBROUTINE RPASSM(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC,
     *    LA,IERR)
      DIMENSION A(N),B(N),C(N),D(N),TRIGS(N)
C
      DIMENSION A10(64),A11(64),A20(64),A21(64),
     *    B10(64),B11(64),B20(64),B21(64)
      DATA SIN36/0.587785252292473/,SIN72/0.951056516295154/,
     *    QRT5/0.559016994374947/,SIN60/0.866025403784437/
C
      M=N/IFAC
      IINK=LA*INC1
      JINK=LA*INC2
      JUMP=(IFAC-1)*JINK
      KSTOP=(N-IFAC)/(2*IFAC)
C
      IBAD=1
      IF (LOT.GT.64) GO TO 910
      IBASE=0
      JBASE=0
      IGO=IFAC-1
      IF (IGO.EQ.7) IGO=6
      IBAD=2
      IF (IGO.LT.1.OR.IGO.GT.6) GO TO 910
      GO TO (200,300,400,500,600,800),IGO
C
C     CODING FOR FACTOR 2
C     -------------------
  200 CONTINUE
      IA=1
      IB=IA+(2*M-LA)*INC1
      JA=1
      JB=JA+JINK
C
      IF (LA.EQ.M) GO TO 290
C
      DO 220 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 210 IJK=1,LOT
      C(JA+J)=A(IA+I)+A(IB+I)
      C(JB+J)=A(IA+I)-A(IB+I)
      I=I+INC3
      J=J+INC4
  210 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  220 CONTINUE
      IA=IA+IINK
      IINK=2*IINK
      IB=IB-IINK
      IBASE=0
      JBASE=JBASE+JUMP
      JUMP=2*JUMP+JINK
      IF (IA.EQ.IB) GO TO 260
      DO 250 K=LA,KSTOP,LA
      KB=K+K
      C1=TRIGS(KB+1)
      S1=TRIGS(KB+2)
      IBASE=0
      DO 240 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 230 IJK=1,LOT
      C(JA+J)=A(IA+I)+A(IB+I)
      D(JA+J)=B(IA+I)-B(IB+I)
      C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)+B(IB+I))
      D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)+B(IB+I))
      I=I+INC3
      J=J+INC4
  230 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  240 CONTINUE
      IA=IA+IINK
      IB=IB-IINK
      JBASE=JBASE+JUMP
  250 CONTINUE
      IF (IA.GT.IB) GO TO 900
  260 CONTINUE
      IBASE=0
      DO 280 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 270 IJK=1,LOT
      C(JA+J)=A(IA+I)
      C(JB+J)=-B(IA+I)
      I=I+INC3
      J=J+INC4
  270 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  280 CONTINUE
      GO TO 900
C
  290 CONTINUE
      DO 294 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 292 IJK=1,LOT
      C(JA+J)=2.0*(A(IA+I)+A(IB+I))
      C(JB+J)=2.0*(A(IA+I)-A(IB+I))
      I=I+INC3
      J=J+INC4
  292 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  294 CONTINUE
      GO TO 900
C
C     CODING FOR FACTOR 3
C     -------------------
  300 CONTINUE
      IA=1
      IB=IA+(2*M-LA)*INC1
      IC=IB
      JA=1
      JB=JA+JINK
      JC=JB+JINK
C
      IF (LA.EQ.M) GO TO 390
C
      DO 320 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 310 IJK=1,LOT
      C(JA+J)=A(IA+I)+A(IB+I)
      C(JB+J)=(A(IA+I)-0.5*A(IB+I))-(SIN60*(B(IB+I)))
      C(JC+J)=(A(IA+I)-0.5*A(IB+I))+(SIN60*(B(IB+I)))
      I=I+INC3
      J=J+INC4
  310 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  320 CONTINUE
      IA=IA+IINK
      IINK=2*IINK
      IB=IB+IINK
      IC=IC-IINK
      JBASE=JBASE+JUMP
      JUMP=2*JUMP+JINK
      IF (IA.EQ.IC) GO TO 360
      DO 350 K=LA,KSTOP,LA
      KB=K+K
      KC=KB+KB
      C1=TRIGS(KB+1)
      S1=TRIGS(KB+2)
      C2=TRIGS(KC+1)
      S2=TRIGS(KC+2)
      IBASE=0
      DO 340 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 330 IJK=1,LOT
      C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I))
      D(JA+J)=B(IA+I)+(B(IB+I)-B(IC+I))
      C(JB+J)=
     *    C1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)+B(IC+I))))
     *   -S1*((B(IA+I)-0.5*(B(IB+I)-B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))))
      D(JB+J)=
     *    S1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)+B(IC+I))))
     *   +C1*((B(IA+I)-0.5*(B(IB+I)-B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))))
      C(JC+J)=
     *    C2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)+B(IC+I))))
     *   -S2*((B(IA+I)-0.5*(B(IB+I)-B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))))
      D(JC+J)=
     *    S2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)+B(IC+I))))
     *   +C2*((B(IA+I)-0.5*(B(IB+I)-B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))))
      I=I+INC3
      J=J+INC4
  330 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  340 CONTINUE
      IA=IA+IINK
      IB=IB+IINK
      IC=IC-IINK
      JBASE=JBASE+JUMP
  350 CONTINUE
      IF (IA.GT.IC) GO TO 900
  360 CONTINUE
      IBASE=0
      DO 380 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 370 IJK=1,LOT
      C(JA+J)=A(IA+I)+A(IB+I)
      C(JB+J)=(0.5*A(IA+I)-A(IB+I))-(SIN60*B(IA+I))
      C(JC+J)=-(0.5*A(IA+I)-A(IB+I))-(SIN60*B(IA+I))
      I=I+INC3
      J=J+INC4
  370 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  380 CONTINUE
      GO TO 900
C
  390 CONTINUE
      SSIN60=2.0*SIN60
      DO 394 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 392 IJK=1,LOT
      C(JA+J)=2.0*(A(IA+I)+A(IB+I))
      C(JB+J)=(2.0*A(IA+I)-A(IB+I))-(SSIN60*B(IB+I))
      C(JC+J)=(2.0*A(IA+I)-A(IB+I))+(SSIN60*B(IB+I))
      I=I+INC3
      J=J+INC4
  392 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  394 CONTINUE
      GO TO 900
C
C     CODING FOR FACTOR 4
C     -------------------
  400 CONTINUE
      IA=1
      IB=IA+(2*M-LA)*INC1
      IC=IB+2*M*INC1
      ID=IB
      JA=1
      JB=JA+JINK
      JC=JB+JINK
      JD=JC+JINK
C
      IF (LA.EQ.M) GO TO 490
C
      DO 420 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 410 IJK=1,LOT
      C(JA+J)=(A(IA+I)+A(IC+I))+A(IB+I)
      C(JB+J)=(A(IA+I)-A(IC+I))-B(IB+I)
      C(JC+J)=(A(IA+I)+A(IC+I))-A(IB+I)
      C(JD+J)=(A(IA+I)-A(IC+I))+B(IB+I)
      I=I+INC3
      J=J+INC4
  410 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  420 CONTINUE
      IA=IA+IINK
      IINK=2*IINK
      IB=IB+IINK
      IC=IC-IINK
      ID=ID-IINK
      JBASE=JBASE+JUMP
      JUMP=2*JUMP+JINK
      IF (IB.EQ.IC) GO TO 460
      DO 450 K=LA,KSTOP,LA
      KB=K+K
      KC=KB+KB
      KD=KC+KB
      C1=TRIGS(KB+1)
      S1=TRIGS(KB+2)
      C2=TRIGS(KC+1)
      S2=TRIGS(KC+2)
      C3=TRIGS(KD+1)
      S3=TRIGS(KD+2)
      IBASE=0
      DO 440 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 430 IJK=1,LOT
      C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I))
      D(JA+J)=(B(IA+I)-B(IC+I))+(B(IB+I)-B(ID+I))
      C(JC+J)=
     *    C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)))
     *   -S2*((B(IA+I)-B(IC+I))-(B(IB+I)-B(ID+I)))
      D(JC+J)=
     *    S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)))
     *   +C2*((B(IA+I)-B(IC+I))-(B(IB+I)-B(ID+I)))
      C(JB+J)=
     *    C1*((A(IA+I)-A(IC+I))-(B(IB+I)+B(ID+I)))
     *   -S1*((B(IA+I)+B(IC+I))+(A(IB+I)-A(ID+I)))
      D(JB+J)=
     *    S1*((A(IA+I)-A(IC+I))-(B(IB+I)+B(ID+I)))
     *   +C1*((B(IA+I)+B(IC+I))+(A(IB+I)-A(ID+I)))
      C(JD+J)=
     *    C3*((A(IA+I)-A(IC+I))+(B(IB+I)+B(ID+I)))
     *   -S3*((B(IA+I)+B(IC+I))-(A(IB+I)-A(ID+I)))
      D(JD+J)=
     *    S3*((A(IA+I)-A(IC+I))+(B(IB+I)+B(ID+I)))
     *   +C3*((B(IA+I)+B(IC+I))-(A(IB+I)-A(ID+I)))
      I=I+INC3
      J=J+INC4
  430 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  440 CONTINUE
      IA=IA+IINK
      IB=IB+IINK
      IC=IC-IINK
      ID=ID-IINK
      JBASE=JBASE+JUMP
  450 CONTINUE
      IF (IB.GT.IC) GO TO 900
  460 CONTINUE
      IBASE=0
      SIN45=SQRT(0.5)
      DO 480 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 470 IJK=1,LOT
      C(JA+J)=A(IA+I)+A(IB+I)
      C(JB+J)=SIN45*((A(IA+I)-A(IB+I))-(B(IA+I)+B(IB+I)))
      C(JC+J)=B(IB+I)-B(IA+I)
      C(JD+J)=-SIN45*((A(IA+I)-A(IB+I))+(B(IA+I)+B(IB+I)))
      I=I+INC3
      J=J+INC4
  470 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  480 CONTINUE
      GO TO 900
C
  490 CONTINUE
      DO 494 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 492 IJK=1,LOT
      C(JA+J)=2.0*((A(IA+I)+A(IC+I))+A(IB+I))
      C(JB+J)=2.0*((A(IA+I)-A(IC+I))-B(IB+I))
      C(JC+J)=2.0*((A(IA+I)+A(IC+I))-A(IB+I))
      C(JD+J)=2.0*((A(IA+I)-A(IC+I))+B(IB+I))
      I=I+INC3
      J=J+INC4
  492 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  494 CONTINUE
      GO TO 900
C
C     CODING FOR FACTOR 5
C     -------------------
  500 CONTINUE
      IA=1
      IB=IA+(2*M-LA)*INC1
      IC=IB+2*M*INC1
      ID=IC
      IE=IB
      JA=1
      JB=JA+JINK
      JC=JB+JINK
      JD=JC+JINK
      JE=JD+JINK
C
      IF (LA.EQ.M) GO TO 590
C
      DO 520 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 510 IJK=1,LOT
      C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I))
      C(JB+J)=((A(IA+I)-0.25*(A(IB+I)+A(IC+I)))+QRT5*(A(IB+I)-A(IC+I)))
     *    -(SIN72*B(IB+I)+SIN36*B(IC+I))
      C(JC+J)=((A(IA+I)-0.25*(A(IB+I)+A(IC+I)))-QRT5*(A(IB+I)-A(IC+I)))
     *    -(SIN36*B(IB+I)-SIN72*B(IC+I))
      C(JD+J)=((A(IA+I)-0.25*(A(IB+I)+A(IC+I)))-QRT5*(A(IB+I)-A(IC+I)))
     *    +(SIN36*B(IB+I)-SIN72*B(IC+I))
      C(JE+J)=((A(IA+I)-0.25*(A(IB+I)+A(IC+I)))+QRT5*(A(IB+I)-A(IC+I)))
     *    +(SIN72*B(IB+I)+SIN36*B(IC+I))
      I=I+INC3
      J=J+INC4
  510 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  520 CONTINUE
      IA=IA+IINK
      IINK=2*IINK
      IB=IB+IINK
      IC=IC+IINK
      ID=ID-IINK
      IE=IE-IINK
      JBASE=JBASE+JUMP
      JUMP=2*JUMP+JINK
      IF (IB.EQ.ID) GO TO 560
      DO 550 K=LA,KSTOP,LA
      KB=K+K
      KC=KB+KB
      KD=KC+KB
      KE=KD+KB
      C1=TRIGS(KB+1)
      S1=TRIGS(KB+2)
      C2=TRIGS(KC+1)
      S2=TRIGS(KC+2)
      C3=TRIGS(KD+1)
      S3=TRIGS(KD+2)
      C4=TRIGS(KE+1)
      S4=TRIGS(KE+2)
      IBASE=0
      DO 540 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 530 IJK=1,LOT
C
      A10(IJK)=(A(IA+I)-0.25*((A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I))))
     *    +QRT5*((A(IB+I)+A(IE+I))-(A(IC+I)+A(ID+I)))
      A20(IJK)=(A(IA+I)-0.25*((A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I))))
     *    -QRT5*((A(IB+I)+A(IE+I))-(A(IC+I)+A(ID+I)))
      B10(IJK)=(B(IA+I)-0.25*((B(IB+I)-B(IE+I))+(B(IC+I)-B(ID+I))))
     *    +QRT5*((B(IB+I)-B(IE+I))-(B(IC+I)-B(ID+I)))
      B20(IJK)=(B(IA+I)-0.25*((B(IB+I)-B(IE+I))+(B(IC+I)-B(ID+I))))
     *    -QRT5*((B(IB+I)-B(IE+I))-(B(IC+I)-B(ID+I)))
      A11(IJK)=SIN72*(B(IB+I)+B(IE+I))+SIN36*(B(IC+I)+B(ID+I))
      A21(IJK)=SIN36*(B(IB+I)+B(IE+I))-SIN72*(B(IC+I)+B(ID+I))
      B11(IJK)=SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))
      B21(IJK)=SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))
C
      C(JA+J)=A(IA+I)+((A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)))
      D(JA+J)=B(IA+I)+((B(IB+I)-B(IE+I))+(B(IC+I)-B(ID+I)))
      C(JB+J)=C1*(A10(IJK)-A11(IJK))-S1*(B10(IJK)+B11(IJK))
      D(JB+J)=S1*(A10(IJK)-A11(IJK))+C1*(B10(IJK)+B11(IJK))
      C(JE+J)=C4*(A10(IJK)+A11(IJK))-S4*(B10(IJK)-B11(IJK))
      D(JE+J)=S4*(A10(IJK)+A11(IJK))+C4*(B10(IJK)-B11(IJK))
      C(JC+J)=C2*(A20(IJK)-A21(IJK))-S2*(B20(IJK)+B21(IJK))
      D(JC+J)=S2*(A20(IJK)-A21(IJK))+C2*(B20(IJK)+B21(IJK))
      C(JD+J)=C3*(A20(IJK)+A21(IJK))-S3*(B20(IJK)-B21(IJK))
      D(JD+J)=S3*(A20(IJK)+A21(IJK))+C3*(B20(IJK)-B21(IJK))
C
      I=I+INC3
      J=J+INC4
  530 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  540 CONTINUE
      IA=IA+IINK
      IB=IB+IINK
      IC=IC+IINK
      ID=ID-IINK
      IE=IE-IINK
      JBASE=JBASE+JUMP
  550 CONTINUE
      IF (IB.GT.ID) GO TO 900
  560 CONTINUE
      IBASE=0
      DO 580 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 570 IJK=1,LOT
      C(JA+J)=(A(IA+I)+A(IB+I))+A(IC+I)
      C(JB+J)=(QRT5*(A(IA+I)-A(IB+I))+(0.25*(A(IA+I)+A(IB+I))-A(IC+I)))
     *    -(SIN36*B(IA+I)+SIN72*B(IB+I))
      C(JE+J)=-(QRT5*(A(IA+I)-A(IB+I))+(0.25*(A(IA+I)+A(IB+I))-A(IC+I)))
     *    -(SIN36*B(IA+I)+SIN72*B(IB+I))
      C(JC+J)=(QRT5*(A(IA+I)-A(IB+I))-(0.25*(A(IA+I)+A(IB+I))-A(IC+I)))
     *    -(SIN72*B(IA+I)-SIN36*B(IB+I))
      C(JD+J)=-(QRT5*(A(IA+I)-A(IB+I))-(0.25*(A(IA+I)+A(IB+I))-A(IC+I)))
     *    -(SIN72*B(IA+I)-SIN36*B(IB+I))
      I=I+INC3
      J=J+INC4
  570 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  580 CONTINUE
      GO TO 900
C
  590 CONTINUE
      QQRT5=2.0*QRT5
      SSIN36=2.0*SIN36
      SSIN72=2.0*SIN72
      DO 594 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 592 IJK=1,LOT
      C(JA+J)=2.0*(A(IA+I)+(A(IB+I)+A(IC+I)))
      C(JB+J)=(2.0*(A(IA+I)-0.25*(A(IB+I)+A(IC+I)))
     *    +QQRT5*(A(IB+I)-A(IC+I)))-(SSIN72*B(IB+I)+SSIN36*B(IC+I))
      C(JC+J)=(2.0*(A(IA+I)-0.25*(A(IB+I)+A(IC+I)))
     *    -QQRT5*(A(IB+I)-A(IC+I)))-(SSIN36*B(IB+I)-SSIN72*B(IC+I))
      C(JD+J)=(2.0*(A(IA+I)-0.25*(A(IB+I)+A(IC+I)))
     *    -QQRT5*(A(IB+I)-A(IC+I)))+(SSIN36*B(IB+I)-SSIN72*B(IC+I))
      C(JE+J)=(2.0*(A(IA+I)-0.25*(A(IB+I)+A(IC+I)))
     *    +QQRT5*(A(IB+I)-A(IC+I)))+(SSIN72*B(IB+I)+SSIN36*B(IC+I))
      I=I+INC3
      J=J+INC4
  592 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  594 CONTINUE
      GO TO 900
C
C     CODING FOR FACTOR 6
C     -------------------
  600 CONTINUE
      IA=1
      IB=IA+(2*M-LA)*INC1
      IC=IB+2*M*INC1
      ID=IC+2*M*INC1
      IE=IC
      IF=IB
      JA=1
      JB=JA+JINK
      JC=JB+JINK
      JD=JC+JINK
      JE=JD+JINK
      JF=JE+JINK
C
      IF (LA.EQ.M) GO TO 690
C
      DO 620 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 610 IJK=1,LOT
      C(JA+J)=(A(IA+I)+A(ID+I))+(A(IB+I)+A(IC+I))
      C(JD+J)=(A(IA+I)-A(ID+I))-(A(IB+I)-A(IC+I))
      C(JB+J)=((A(IA+I)-A(ID+I))+0.5*(A(IB+I)-A(IC+I)))
     *    -(SIN60*(B(IB+I)+B(IC+I)))
      C(JF+J)=((A(IA+I)-A(ID+I))+0.5*(A(IB+I)-A(IC+I)))
     *    +(SIN60*(B(IB+I)+B(IC+I)))
      C(JC+J)=((A(IA+I)+A(ID+I))-0.5*(A(IB+I)+A(IC+I)))
     *    -(SIN60*(B(IB+I)-B(IC+I)))
      C(JE+J)=((A(IA+I)+A(ID+I))-0.5*(A(IB+I)+A(IC+I)))
     *    +(SIN60*(B(IB+I)-B(IC+I)))
      I=I+INC3
      J=J+INC4
  610 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  620 CONTINUE
      IA=IA+IINK
      IINK=2*IINK
      IB=IB+IINK
      IC=IC+IINK
      ID=ID-IINK
      IE=IE-IINK
      IF=IF-IINK
      JBASE=JBASE+JUMP
      JUMP=2*JUMP+JINK
      IF (IC.EQ.ID) GO TO 660
      DO 650 K=LA,KSTOP,LA
      KB=K+K
      KC=KB+KB
      KD=KC+KB
      KE=KD+KB
      KF=KE+KB
      C1=TRIGS(KB+1)
      S1=TRIGS(KB+2)
      C2=TRIGS(KC+1)
      S2=TRIGS(KC+2)
      C3=TRIGS(KD+1)
      S3=TRIGS(KD+2)
      C4=TRIGS(KE+1)
      S4=TRIGS(KE+2)
      C5=TRIGS(KF+1)
      S5=TRIGS(KF+2)
      IBASE=0
      DO 640 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 630 IJK=1,LOT
C
      A11(IJK)= (A(IE+I)+A(IB+I))+(A(IC+I)+A(IF+I))
      A20(IJK)=(A(IA+I)+A(ID+I))-0.5*A11(IJK)
      A21(IJK)=SIN60*((A(IE+I)+A(IB+I))-(A(IC+I)+A(IF+I)))
      B11(IJK)= (B(IB+I)-B(IE+I))+(B(IC+I)-B(IF+I))
      B20(IJK)=(B(IA+I)-B(ID+I))-0.5*B11(IJK)
      B21(IJK)=SIN60*((B(IB+I)-B(IE+I))-(B(IC+I)-B(IF+I)))
C
      C(JA+J)=(A(IA+I)+A(ID+I))+A11(IJK)
      D(JA+J)=(B(IA+I)-B(ID+I))+B11(IJK)
      C(JC+J)=C2*(A20(IJK)-B21(IJK))-S2*(B20(IJK)+A21(IJK))
      D(JC+J)=S2*(A20(IJK)-B21(IJK))+C2*(B20(IJK)+A21(IJK))
      C(JE+J)=C4*(A20(IJK)+B21(IJK))-S4*(B20(IJK)-A21(IJK))
      D(JE+J)=S4*(A20(IJK)+B21(IJK))+C4*(B20(IJK)-A21(IJK))
C
      A11(IJK)=(A(IE+I)-A(IB+I))+(A(IC+I)-A(IF+I))
      B11(IJK)=(B(IE+I)+B(IB+I))-(B(IC+I)+B(IF+I))
      A20(IJK)=(A(IA+I)-A(ID+I))-0.5*A11(IJK)
      A21(IJK)=SIN60*((A(IE+I)-A(IB+I))-(A(IC+I)-A(IF+I)))
      B20(IJK)=(B(IA+I)+B(ID+I))+0.5*B11(IJK)
      B21(IJK)=SIN60*((B(IE+I)+B(IB+I))+(B(IC+I)+B(IF+I)))
C
      C(JD+J)=
     *  C3*((A(IA+I)-A(ID+I))+A11(IJK))-S3*((B(IA+I)+B(ID+I))-B11(IJK))
      D(JD+J)=
     *  S3*((A(IA+I)-A(ID+I))+A11(IJK))+C3*((B(IA+I)+B(ID+I))-B11(IJK))
      C(JB+J)=C1*(A20(IJK)-B21(IJK))-S1*(B20(IJK)-A21(IJK))
      D(JB+J)=S1*(A20(IJK)-B21(IJK))+C1*(B20(IJK)-A21(IJK))
      C(JF+J)=C5*(A20(IJK)+B21(IJK))-S5*(B20(IJK)+A21(IJK))
      D(JF+J)=S5*(A20(IJK)+B21(IJK))+C5*(B20(IJK)+A21(IJK))
C
      I=I+INC3
      J=J+INC4
  630 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  640 CONTINUE
      IA=IA+IINK
      IB=IB+IINK
      IC=IC+IINK
      ID=ID-IINK
      IE=IE-IINK
      IF=IF-IINK
      JBASE=JBASE+JUMP
  650 CONTINUE
      IF (IC.GT.ID) GO TO 900
  660 CONTINUE
      IBASE=0
      DO 680 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 670 IJK=1,LOT
      C(JA+J)=A(IB+I)+(A(IA+I)+A(IC+I))
      C(JD+J)=B(IB+I)-(B(IA+I)+B(IC+I))
      C(JB+J)=(SIN60*(A(IA+I)-A(IC+I)))-(0.5*(B(IA+I)+B(IC+I))+B(IB+I))
      C(JF+J)=-(SIN60*(A(IA+I)-A(IC+I)))-(0.5*(B(IA+I)+B(IC+I))+B(IB+I))
      C(JC+J)=SIN60*(B(IC+I)-B(IA+I))+(0.5*(A(IA+I)+A(IC+I))-A(IB+I))
      C(JE+J)=SIN60*(B(IC+I)-B(IA+I))-(0.5*(A(IA+I)+A(IC+I))-A(IB+I))
      I=I+INC3
      J=J+INC4
  670 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  680 CONTINUE
      GO TO 900
C
  690 CONTINUE
      SSIN60=2.0*SIN60
      DO 694 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 692 IJK=1,LOT
      C(JA+J)=(2.0*(A(IA+I)+A(ID+I)))+(2.0*(A(IB+I)+A(IC+I)))
      C(JD+J)=(2.0*(A(IA+I)-A(ID+I)))-(2.0*(A(IB+I)-A(IC+I)))
      C(JB+J)=(2.0*(A(IA+I)-A(ID+I))+(A(IB+I)-A(IC+I)))
     *    -(SSIN60*(B(IB+I)+B(IC+I)))
      C(JF+J)=(2.0*(A(IA+I)-A(ID+I))+(A(IB+I)-A(IC+I)))
     *    +(SSIN60*(B(IB+I)+B(IC+I)))
      C(JC+J)=(2.0*(A(IA+I)+A(ID+I))-(A(IB+I)+A(IC+I)))
     *    -(SSIN60*(B(IB+I)-B(IC+I)))
      C(JE+J)=(2.0*(A(IA+I)+A(ID+I))-(A(IB+I)+A(IC+I)))
     *    +(SSIN60*(B(IB+I)-B(IC+I)))
      I=I+INC3
      J=J+INC4
  692 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  694 CONTINUE
      GO TO 900
C
C     CODING FOR FACTOR 8
C     -------------------
  800 CONTINUE
      IBAD=3
      IF (LA.NE.M) GO TO 910
      IA=1
      IB=IA+LA*INC1
      IC=IB+2*LA*INC1
      ID=IC+2*LA*INC1
      IE=ID+2*LA*INC1
      JA=1
      JB=JA+JINK
      JC=JB+JINK
      JD=JC+JINK
      JE=JD+JINK
      JF=JE+JINK
      JG=JF+JINK
      JH=JG+JINK
      SSIN45=SQRT(2.0)
C
      DO 820 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 810 IJK=1,LOT
      C(JA+J)=2.0*(((A(IA+I)+A(IE+I))+A(IC+I))+(A(IB+I)+A(ID+I)))
      C(JE+J)=2.0*(((A(IA+I)+A(IE+I))+A(IC+I))-(A(IB+I)+A(ID+I)))
      C(JC+J)=2.0*(((A(IA+I)+A(IE+I))-A(IC+I))-(B(IB+I)-B(ID+I)))
      C(JG+J)=2.0*(((A(IA+I)+A(IE+I))-A(IC+I))+(B(IB+I)-B(ID+I)))
      C(JB+J)=2.0*((A(IA+I)-A(IE+I))-B(IC+I))
     *    +SSIN45*((A(IB+I)-A(ID+I))-(B(IB+I)+B(ID+I)))
      C(JF+J)=2.0*((A(IA+I)-A(IE+I))-B(IC+I))
     *    -SSIN45*((A(IB+I)-A(ID+I))-(B(IB+I)+B(ID+I)))
      C(JD+J)=2.0*((A(IA+I)-A(IE+I))+B(IC+I))
     *    -SSIN45*((A(IB+I)-A(ID+I))+(B(IB+I)+B(ID+I)))
      C(JH+J)=2.0*((A(IA+I)-A(IE+I))+B(IC+I))
     *    +SSIN45*((A(IB+I)-A(ID+I))+(B(IB+I)+B(ID+I)))
      I=I+INC3
      J=J+INC4
  810 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  820 CONTINUE
C
C     RETURN
C     ------
  900 CONTINUE
      IBAD=0
  910 CONTINUE
      IERR=IBAD
      RETURN
      END
C     ***************************************************************
      SUBROUTINE QPASSM(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC,
     *    LA,IERR)
      DIMENSION A(N),B(N),C(N),D(N),TRIGS(N)
C
      RETURN
      END
C     ***************************************************************
C
C     Dummy subroutines for ECMWF only program library.
C
      SUBROUTINE INIARB
C
      RETURN
      END
C     *********************************************************
      SUBROUTINE READARB
C
      RETURN
      END
C     *********************************************************
      SUBROUTINE INIRS
C
      RETURN
      END
C     *********************************************************
      SUBROUTINE LEGDERV
C
      RETURN
      END
C     *********************************************************
      SUBROUTINE RSCOEFFS
C
      RETURN
      END
C     *********************************************************
      SUBROUTINE RSP2GRID
C
      RETURN
      END
C     *********************************************************
      SUBROUTINE INIUM
C
      RETURN
      END
C     *********************************************************
      SUBROUTINE READUM
C
      RETURN
      END
C     *********************************************************
      SUBROUTINE MAKEUM(FSTEM,IOFFSET,INPFNAME,NCDATE)
C
      RETURN
      END
C     *********************************************************
      SUBROUTINE CDXDAT(KCD,KD,KM,KY)
C
C             THIS SUBROUTINE CONVERTS
C             KCD       CENTURY DATE
C             BACK TO
C             KD        DAY
C             KM        MONTH
C             KY        YEAR (IN THE FORM 19XX, 20XX)
C
C----------------------------------------------------------------------
C
      DIMENSION IDAYS(12),JDAYS(12)
      DATA IDAYS/0,31,59,90,120,151,181,212,243,273,304,334/
      DATA JDAYS/0,31,60,91,121,152,182,213,244,274,305,335/
C             FIND APPROXIMATE YEAR
C  NEW CODE
      IIKCD=KCD
      IKCD=KCD
      IF(KCD.GT.36524) THEN
         IKCD=KCD-36525
      ENDIF
      KY=IKCD/365
      NDAYS=MOD(IKCD,365)
C             SUBTRACT 1 DAY FOR EACH LEAP YEAR
      ILY=(KY-1)/4
      if(ky.eq.0) ily=-1
      NDAYS=NDAYS-ILY
      IF (NDAYS.GT.0) GO TO 10
C             ADD A YEAR IF NECCESSARY TO COMPENSATE FOR L.Y. DAYS
      NDAYS=NDAYS+365
      KY=KY-1
      IF (MOD(KY,4).EQ.0) NDAYS=NDAYS+1
   10 CONTINUE
C             CORRECT YEAR FOR CENTURY
      KY=KY+1900
      IF(KCD.GT.36524) KY=KY+100
C             TEST FOR CURRENT YEAR LEAP YEAR
      IF (MOD(KY,4).EQ.0) GO TO 30
C             NON LEAP YEAR
      DO 20 J=1,11
      IF (IDAYS(J+1).GE.NDAYS) GO TO 25
   20 CONTINUE
      J=12
   25 CONTINUE
      KM=J
      KD=NDAYS-IDAYS(J)
      RETURN
C----------------------------------------------------------------------
C             LEAP YEAR
   30 CONTINUE
      DO 40 J=1,11

      IF (JDAYS(J+1).GE.NDAYS) GO TO 45
   40 CONTINUE
      J=12
   45 CONTINUE
      KM=J
      KD=NDAYS-JDAYS(J)
C
      RETURN
      END
C     ***************************************************************
      FUNCTION IDATXC(KD,KM,KY)
C
C             THIS FUNCTION RETURNS CENTURY DAY GIVEN
C             KD        DAY
C             KM        MONTH
C             KY        YEAR (19XX, 20XX OR XX)
C
C----------------------------------------------------------------------
C
      DIMENSION IDAYS(12),JDAYS(12)
      DATA IDAYS/0,31,59,90,120,151,181,212,243,273,304,334/
      DATA JDAYS/0,31,60,91,121,152,182,213,244,274,305,335/
      IY=MOD(KY,100)
      IYDAY=IDAYS(KM)+KD
      IF (MOD(IY,4).EQ.0) IYDAY=JDAYS(KM)+KD
      ILY=(IY-1)/4
      IF(KY.EQ.1900.OR.KY.EQ.00.OR.KY.EQ.2000) ILY=-1
      IDATXC=IY*365+ILY+IYDAY
      IF(KY.GE.2000) IDATXC=IDATXC+36525
C
      RETURN
      END
C     ***********************************************************
      SUBROUTINE CDXDAT2000(KCD,KD,KM,KY)
C
C             THIS SUBROUTINE CONVERTS
C             KCD       DAY SINCE 1/1/1900
C             BACK TO
C             KD        DAY
C             KM        MONTH
C             KY        YEAR (IN THE FORM YYYY)
C
C     Assuming all years nn00 are leap years
C     (true for 2000,2400,.. but not for 1900,2100,etc).
C----------------------------------------------------------------------
C
      INTEGER KCD,KD,KM,KY,IY
      DIMENSION IDAYS(12),JDAYS(12)
      DATA IDAYS/0,31,59,90,120,151,181,212,243,273,304,334/
      DATA JDAYS/0,31,60,91,121,152,182,213,244,274,305,335/
C             FIND CENTURY
      NDPCEN=36525
      ICEN=KCD/NDPCEN+19
      IKCD=MOD(KCD,NDPCEN)
C             ESTIMATE YEAR
      IY=IKCD/365
      NDAYS=MOD(IKCD,365)
C             SUBTRACT 1 DAY FOR EACH LEAP YEAR IN THE CENTURY
      ILY=(IY-1)/4+1
      IF (IY.EQ.0) ILY=0
      NDAYS=NDAYS-ILY
      IF (NDAYS.LE.0) THEN
C             ADD A YEAR IF NECCESSARY TO COMPENSATE FOR L.Y. DAYS
         NDAYS=NDAYS+365
         IY=IY-1
         IF (MOD(IY,4).EQ.0) NDAYS=NDAYS+1
      ENDIF
C             TEST FOR CURRENT YEAR LEAP YEAR
      IF (MOD(IY,4).EQ.0) THEN
C             LEAP YEAR
         DO 40 J=1,11
            IF (JDAYS(J+1).GE.NDAYS) GO TO 45
 40      CONTINUE
         J=12
 45      CONTINUE
         KM=J
         KD=NDAYS-JDAYS(J)
      ELSE
C             NON LEAP YEAR
         DO 20 J=1,11
            IF (IDAYS(J+1).GE.NDAYS) GO TO 25
 20      CONTINUE
         J=12
 25      CONTINUE
         KM=J
         KD=NDAYS-IDAYS(J)
      ENDIF
      KY=ICEN*100+IY
C
      RETURN
      END
C     ***************************************************************
      FUNCTION IDATXC2000(KD,KM,KY)
C
C             THIS FUNCTION RETURNS DAY SINCE 1/1/1900 GIVEN
C             KD        DAY
C             KM        MONTH
C             KY        YEAR (YYYY)
C
C     Assuming all years nn00 are leap years
C     (true for 2000,2400,.. but not for 1900,2100,etc).
C----------------------------------------------------------------------
C
      INTEGER KD,KM,KY,IY
      DIMENSION IDAYS(12),JDAYS(12)
      DATA IDAYS/0,31,59,90,120,151,181,212,243,273,304,334/
      DATA JDAYS/0,31,60,91,121,152,182,213,244,274,305,335/
C
      IY=MOD(KY,100)
      ICEN=KY/100
      NDPCEN=36525
      IYDAY=IDAYS(KM)+KD
      IF (MOD(IY,4).EQ.0) IYDAY=JDAYS(KM)+KD
      ILY=(IY-1)/4+1
      IF (IY.EQ.0) ILY=0
      IDATXC2000=(ICEN-19)*NDPCEN+IY*365+ILY+IYDAY
C
      RETURN
      END
C     ***********************************************************
