*COMDECK PARAM1                                                            PARAM1.1     
      PARAMETER(MM=21,NN=21,NL=15,NHEM=1,MOCT=1,MG=64,JG=16,NWJ2=121       PARAM1.2     
     :,NCRAY=64,JGL=JG,NTHSF=5)                                            PARAM1.3     
      PARAMETER(NSG=12,NGP=NSG+2,NXD=39,NXDF=NXD,NTH=4,NPH=6,NXP=19        XDTEM3.1     
     :,NTF=5,NTFFLD=3*NTF                                                  TMAV5.1     
     :,NPMAX4=1001,NPMAX5=1001,NPMAX9=1001,NTERM5=27)                      PARAM1.5     
*COMDECK PARAM2                                                            PARAM2.1     
      PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI                            PARAM2.2     
     :,JGM=JG-1,JGP=JG+1,JGG=JG*NHEM,JGGM=JGG-1,JGGM2=JGG-2,JGGP=JGG+1     PARAM2.3     
     :,MGP=MG+1,MGPP=MG+2,NLM=NL-1,NLP=NL+1,NL2=NL*NL,MJP=NWJ2+NWJ2        PARAM2.4     
     :,NNP=NN+1,NWW=1+(MM-1)/MOCT,NWP=1+MM/MOCT,MOCTP=MOCT+1               PARAM2.5     
     :,IDA=3*MG/2+1,IDD=MGPP*NL,IDF=NCRAY*MGP,IDG=JG*NL                    PARAM2.6     
     :,IDH=MG*JG,IDL=MGPP/2,IDK=IDL*NL,IDM=NNP/2,IDN=IDM*NL                UTF14.1     
     :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGC=MGPP*NHEM,IGD=IDD*NHEM,IGG=IDG*NHEM    PARAM2.8     
     :,IGH=IDH*NHEM,IGL=IDL*NHEM,IGK=IDK*NHEM,IGM=IDM*NHEM,IGN=IDN*NHEM    UTF14.2     
     :,NLWG=10*NL+3,IDTHSF=IGC*NTHSF,IDDZ=NXDF*IGG,IPPZ=NXP*IGG            PARAM2.10    
     :,ILS1=2*(5*NL+1)*IGA                                                 BUGS2.1     
     :,ILG2=IGD*JG, ILG6=IDTHSF*JG*NTH, ILG7=IGC*JG*2*NPH                  PADLEN.2     
     :,ILFA=(2*(ILG6/ILG7))/(1+ILG6/ILG7), ILGA=ILG6*ILFA+ILG7*(1-ILFA)    PADLEN.3     
     :,ILFB=(2*(ILG2/ILGA))/(1+ILG2/ILGA), ILGB=ILG2*ILFB+ILGA*(1-ILFB)    PADLEN.4     
     :,ILFC=(ILGB-ILS1+1)/(ILGB-ILS1), ISPAD=(ILGB-ILS1)*ILFC+2*(1-ILFC)   PADLEN.5     
     : )                                                                   PADLEN.6     
      PARAMETER(IAV=ILGB/JG)                                               TMAV5.2     
C                                                                          PARAM2.12    
*COMDECK BATS                                                              BATS.1     
      COMMON/BATS/ALAT(JGG),AQ(NL2),G(NL2),TAU(NL2),RGG(NL2)               BATS.2     
     :,KOUNT,KSTART,KEND,KITS,KONTM,KHDAY,DAY                              BATS.3     
     :,DELT,DELT2,FTAV,NRTAV,LTAV,LSSD,LDRY                                BATS.4     
      LOGICAL LTAV,LSSD,LDRY                                               BATS.5     
C                                                                          BATS.6     
*COMDECK BLANK                                                             BLANK.1     
      COMMON/BLANK/ SQ(NNP),RSQ(NNP),SIGMAH(NLM),SIGMA(NL),SIGM1K(NL)      BLANK.2     
     :,SIGMAK(NL),T01S2(NLM),TMEAN(NL),ALPHA(NL),DSIGMA(NL),RDSIG(NL)      BLANK.3     
     :,TKP(NL),C(NL2),DRAG(NL),RNWN(NN)                                    BLANK.4     
     :,TSPD,GA,WW,RADEA,P0,EZ,AKAP,RD,RV,CPD,CLATNT                        BLANK.5     
     :,CPHASE,CV,CG,CT,CQ,CTT,CMBHR,CEP,CERT                               BLANK.6     
     :,DAMP,AKK,NDEL,NDELH,NDELHM                                          BLANK.7     
     :,MF,MFP,NF,NFP,MFPP,NFPP,RMG                                         BLANK.8     
      COMPLEX EZ,AIOCT                                                     BLANK.9     
C                                                                          BLANK.10    
*COMDECK COMFFT                                                            COMFFT.1     
      COMMON/COMFFT/NTWG,NRSTWG,NTNL,NRSTNL,TRIG(IDA),WORK(IDF),IFAX(10)   COMFFT.2     
C                                                                          COMFFT.3     
*COMDECK COMGEN                                                            COMGEN.1     
      COMMON/COMGEN/NPTS5,TIGZ(NL),TIGE(NL),TIDZ(NL),TIDE(NL)              COMGEN.2     
     :,TRNS(NL),TRNZ(NL),TRKZ(NL),TDRZ(NL),TDRE(NL)                        COMGEN.3     
     :,WMN(NL),TMN(NL),HMN(NL),WMNN,TMNN,HMNN                              COMGEN.4     
     :,TNS,TNZ,TNE,TKZ,TKE,TGS,TGZ,TGE,TDZ,TDE                             COMGEN.5     
     :,TCNZE,TCKZE,TCZZ,TCEE,TCSZ,TCSE,TCNSZ,TCNSE                         COMGEN.6     
     :,FIGZ,FIGE,FIDZ,FIDE,FRNS,FRNZ,FRKZ,FDRZ,FDRE                        COMGEN.7     
     :,SNS,SNZ,SNE,SKZ,SKE,SGS,SGZ,SGE,SDZ,SDE                             COMGEN.8     
     :,SCNZE,SCKZE,SCZZ,SCEE,SCSZ,SCSE,SCNSZ,SCNSE                         COMGEN.9     
     :,SIGZ,SIGE,SIDZ,SIDE,SRNS,SRNZ,SRKZ,SDRZ,SDRE                        COMGEN.10    
C                                                                          COMGEN.11    
*COMDECK COMGRM                                                            COMGRM.1     
      COMMON/COMGRM/DUDLSG(IGC,NL),DVDLSG(IGC,NL),DTDLSG(IGC,NL)           COMGRM.2     
     :,INTRL(IGC,NL)                                                       COMGRM.3     
C                                                                          COMGRM.4     
*COMDECK COMIOC                                                            COMIOC.1     
      COMMON/COMIOC/NCFICH,NCHIST,NCREST,NCSURF                            COMIOC.2     
     :,NCTFI,NCTFO,NCTADD                                                  TMAV5.3     
     :,NCROGG,NCROGS,NCSTH,NCST4(2),NCPLOT(3)                              COMIOC.3     
     :,NCLEG,NCGEN,NCGDG,NCTHG,NCGP(NGP)                                   BUGS4.1     
     :,NLENTD,NLENHD,NLENWD                                                UCOS.1     
C                                                                          COMIOC.5     
      COMMON/COMIOL/LCHAN,LCHAN2                                           COMIOC.6     
     :,CPTHTD,CPTHHD,CPTHWD                                                UCOS.2     
     :,CBLANK                                                              UCOS.3     
      CHARACTER*8 LCHAN,LCHAN2                                             COMIOC.7     
      CHARACTER*80 CPTHTD,CPTHHD,CPTHWD                                    UCOS.4     
      CHARACTER*1 CBLANK                                                   UCOS.5     
C                                                                          COMIOC.8     
*COMDECK COMMSK                                                            COMMSK.1     
      COMMON/COMMSK/P3MSK(JGG,2)                                           DIMFILM.4     
     :,P2MIN,PMFAC,LMSK2,LMSK3,IMSK                                        COMMSK.3     
      LOGICAL LMSK2,LMSK3                                                  COMMSK.4     
C                                                                          COMMSK.5     
*COMDECK COMPRL                                                            COMPRL.1     
      COMMON/COMPRL/PSG(IGC,NL),PSRF(IGC),TSRF(IGC),OMSRF(IGC)             COMPRL.2     
     :,PSGMX(NL,NHEM),PSGMN(NL,NHEM)                                       COMPRL.3     
     :,LINTP2,LINTP3,NLPR,PPR(NL),PLOUT(NL)                                COMPRL.4     
     :,LXTRP2,LXTRP3,XLAPSE                                                COMPRL.5     
      LOGICAL LINTP2,LINTP3,LXTRP2,LXTRP3                                  COMPRL.6     
C                                                                          COMPRL.7     
*COMDECK COMROG                                                            COMROG.1     
      COMMON/COMROG/GSG(IGC,JGL),LROG,LROGGR,LROGPL,ROGFAC,ROGINC          COMROG.2     
      LOGICAL LROG,LROGGR,LROGPL                                           COMROG.3     
C                                                                          COMROG.4     
*COMDECK COMUTF                                                            COMUTF.1     
      COMMON/CMCUTF/CHT1,CHT2,CFR1,CFR1U,CFR1V,CFR2,CFR2D,CFR2T            UTF14.3     
      CHARACTER*50  CHT1,CHT2,CFR1,CFR1U,CFR1V,CFR2,CFR2D,CFR2T            UTF14.4     
C                                                                          COMUTF.9     
      COMMON/CMIUTF/IHR1(15),IFR3(15)                                      COMUTF.10    
C                                                                          COMUTF.11    
*COMDECK DUM                                                               DUM.1     
      COMMON/DUM/GVE(IGH,3),GVZ(JGG,NL)                                    UTF14.5     
C                                                                          DUM.3     
*COMDECK GRIDP                                                             GRIDP.1     
C     Array ordering in GRIDP and SPECTR must correspond.                  GRIDP.2     
C                                                                          GRIDP.3     
      COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),QG(IGD),HG(IGD)         GRIDP.4     
     :,TG(IGD),PLG(IGC),TYG(IGD),PJG(IGC),TXG(IGD),PMG(IGC),SFG(IGD)       GRIDP.5     
     :,OMG(IGD),GHG(IGD),THG(IGD),EPVG(IGD),FUG(IGD),FVG(IGD),PMSLG(IGC)   GRIDP.6     
     :,UTHG(IDTHSF),VTHG(IDTHSF),ERTHG(IDTHSF),PTHG(IDTHSF)                GRIDP.7     
C                                                                          GRIDP.8     
*COMDECK INPB                                                              INPB.1     
      NAMELIST /INPB/ LSSD,RNTAPE,TSPD,KITS,TMEAN                          INPB.2     
     :,GA,RD,RV,AKAP,CLATNT,RADEA,WW,P0                                    INPB.3     
     :,TDISS,NDEL,RESTIM,DRAG                                              INPB.4     
     :,BEGDAY,ENDDAY,KOUNTD,KOUNTP,KOUNTF,KOUNTA,KOUNTE                    INPB.5     
     :,NPCA,IASCII,IZGTYP,NLAT,NLONG                                       UTF14.6     
     :,NPC1,NCOEFF,LSPO                                                    INPB.7     
     :,NPC2,LPC2,LSGEDY,LSGGRZ,LSGPLZ,LGPO,LGFO,LSGGR,LSGPL,SGFAC,SGINC    INPB.8     
     :,NPC3,LPC3,LXDGR,LXDPL,XDFAC,XDINC                                   INPB.9     
     :,NPC4,LSPPLT                                                         BUGS4.2     
     :,NPC5,LPC5,LENCOP                                                    GENPLT1.1     
     :,NPC6,LPC6,THSURD,CPHASE,LTHGR,LTHPL,THFAC,THINC                     INPB.12    
     :,NPC7,LPC7,LPHGR,LPHPL,PHFAC,PHINC                                   INPB.14    
     :,NPC8,LPC8,LXPGR,LXPPL,XPFAC,XPINC                                   INPB.15    
     :,NPC9,LPC9,LPHCOP                                                    INPB.16    
     :,LINTP2,LINTP3,LXTRP2,LXTRP3,NLPR,PLOUT                              INPB.17    
     :,LROG,LROGGR,LROGPL,ROGFAC,ROGINC,LMSK2,LMSK3                        INPB.18    
     :,NAME                                                                DIMFILM.2     
C                                                                          INPB.20    
*COMDECK INTM                                                              INTM.1     
      NAMELIST /INTM/ LDAILY,LTIMAV,LTFLUX,LTMAC                           INTM.2     
     :,LTFGR,LTFPL,TFFAC,TFINC                                             INTM.3     
     :,LTFGRZ,LTFPLZ,TFFACZ,TFINCZ                                         INTM.4     
C                                                                          INTM.5     
*COMDECK INPHYS                                                            INPHYS.1     
      NAMELIST /INPHYS/ BEGDP,LDRY,LBL,LVD,LCR,LLR,LRD,CD,AKVV             INPHYS.2     
C                                                                          INPHYS.3     
*COMDECK LEGAU                                                             LEGAU.1     
      COMMON/LEGAU/ALP(MJP,JGL),DALP(MJP,JGL),RLP(MJP,JGL),RDLP(MJP,JGL)   LEGAU.2     
     :,SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG)     LEGAU.3     
     :,JH,JL,JINC,EXN1,EXN2,EXS1,EXS2,EXE1,EXE2,EXE3                       LEGAU.4     
C                                                                          LEGAU.5     
*COMDECK MSKEQV                                                            MSKEQV.1     
*CALL GRIDP                                                                MSKEQV.2     
      REAL P2MSK(MGP,JGGP)                                                 MSKEQV.3     
      EQUIVALENCE (P2MSK(1,1),UG(1))                                       MSKEQV.4     
C                                                                          MSKEQV.5     
*COMDECK OUTCON                                                            OUTCON.1     
      COMMON/OUTCON/RNTAPE,KOUNTD,KOUNTP,KOUNTF,KOUNTA,KOUNTE              OUTCON.2     
     :,LOUTP,LOUTF,LOUTA,LOUTE,LOUT,NLAT,NLONG,INLAT,INLONG                OUTCON.3     
     :,NPCA,IASCII,IZGTYP                                                  UTF14.7     
     :,NPC1,NCOEFF,INSPC,LSPO(NL)                                          OUTCON.5     
     :,NPC2,LPC2,LSGEDY,LSGGRZ,LSGPLZ,LGPO(NL),LGFO(NL)                    OUTCON.6     
     :     ,LSGGR(NSG),LSGPL(NSG),SGFAC(NSG),SGINC(NSG)                    OUTCON.7     
     :,NPC3,LPC3,LXDGR(NXD),LXDPL(NXD),XDFAC(NXD),XDINC(NXD)               OUTCON.8     
     :,NPC4,LSPPLT                                                         BUGS4.3     
     :,NPC5,LPC5,LENCOP                                                    GENPLT1.2     
     :,NPC6,LPC6,THSURD(NTHSF),THSURF(NTHSF),LTHGR(NTH),LTHPL(NTH)         OUTCON.12    
     :     ,THFAC(NTH),THINC(NTH)                                          OUTCON.13    
     :,NPC7,LPC7,LPHGR(NPH),LPHPL(NPH),PHFAC(NPH),PHINC(NPH)               OUTCON.14    
     :,NPC8,LPC8,LXPGR(NXP),LXPPL(NXP),XPFAC(NXP),XPINC(NXP)               OUTCON.15    
     :,NPC9,LPC9,LPHCOP                                                    OUTCON.16    
      LOGICAL LOUTP,LOUTF,LOUTA,LOUTE,LOUT                                 OUTCON.17    
     :,LPC2,LPC3,LPC5,LPC6,LPC7,LPC8,LPC9                                  OUTCON.18    
     :,LSPO,LGPO,LGFO,LSGEDY,LSGGRZ,LSGPLZ,LSGGR,LSGPL,LXDGR,LXDPL         OUTCON.19    
     :,LSPPLT,LENCOP,LTHGR,LTHPL,LPHGR,LPHPL,LXPGR,LXPPL,LPHCOP            BUGS4.4     
C                                                                          OUTCON.21    
*COMDECK PHYS                                                              PHYS.1     
      COMMON/PHYS/LBL,LVD,LCR,LLR,LRD,TSTAR(JG,NHEM),QSTAR(JG,NHEM)        PHYS.2     
     :,CD,BLCON,BLVAD,AKVV,ESCONA,ESCONB,FB(NLM)                           PHYS.3     
     :,KBEGP                                                               PHYS.4     
      LOGICAL LBL,LVD,LCR,LLR,LRD                                          PHYS.5     
C                                                                          PHYS.6     
*COMDECK POLYNO                                                            POLYNO.1     
      COMMON/POLYNO/POLY(NWJ2,NHEM),CMPA(IGL)                              POLYNO.2     
      COMPLEX CMPA                                                         POLYNO.3     
C                                                                          POLYNO.4     
*COMDECK SERIES                                                            SERIES.1     
      COMMON/SERIES/ADAY(NPMAX5),AEN(NPMAX5,5),ACONV(NPMAX5,15)            SERIES.2     
C                                                                          SERIES.3     
*COMDECK SPEC                                                              SPEC.1     
      COMMON/SPEC/ZL(NNP,NWP),DL(NNP,NWP),RKE(NNP,NLP,2),RKEFAC            SPEC.2     
     :,RKET(NNP,NLP,2)                                                     KSPEC2.1     
     :,EDAY(NPMAX4),NPTS4                                                  SPEC.3     
      COMPLEX ZL,DL                                                        SPEC.4     
C                                                                          SPEC.5     
*COMDECK SPECTR                                                            SPECTR.1     
C     Array ordering in GRIDP and SPECTR must correspond.                  SPECTR.2     
C                                                                          SPECTR.3     
      COMMON/SPECTR/Z(IGB),D(IGB),Q(IGB),H(IGB),T(IGB),SP(IGA)             SPECTR.4     
     :,SPAD(ISPAD),GS(IGA),ZRES(IGN),DRES(IGN),TRES(IGN)                   SPECTR.5     
      COMPLEX Z,D,T,Q,H,SP,GS                                              SPECTR.6     
C                                                                          SPECTR.7     
*COMDECK TAV                                                               TAV.1     
C     Array ordering in ZONAV and TAV must correspond.                     TAV.2     
C                                                                          TAV.3     
      COMMON/TAV/UBT(JGG,NL),THBT(JGG,NL),TBT(JGG,NL),SFMCT(JGG,NL)        TAV.4     
     :,UVBT(JGG,NL),UWBT(JGG,NL),VTBT(JGG,NL),WTBT(JGG,NL),AKZT(JGG,NL)    TAV.5     
     :,AKET(JGG,NL),EPFHT(JGG,NL),EPFVT(JGG,NL),EPDHT(JGG,NL)              TAV.6     
     :,EPDVT(JGG,NL),EPDTT(JGG,NL),ENSQT(JGG,NL)                           TAV.7     
     :,QYT(JGG,NL),TPWNT(JGG,NL),TMTRST(JGG,NL)                            TAV.8     
     :,WBT(JGG,NL),WBTBT(JGG,NL),VBT(JGG,NL),VBTBT(JGG,NL),QBT(JGG,NL)     TAV.9     
     :,RHBT(JGG,NL),VQBT(JGG,NL),WQBT(JGG,NL),HBT(JGG,NL)                  TAV.10    
     :,TEMSFBT(JGG,NL),TEMVBT(JGG,NL),TEMWBT(JGG,NL)                       XDTEM3.2     
     :,UUBT(JGG,NL),VVBT(JGG,NL),VWBT(JGG,NL),TTBT(JGG,NL)                 TAV.11    
     :,HTBT(JGG,NL),HBTBT(JGG,NL),FUZRT(JGG,NL),FUERT(JGG,NL)              TAV.12    
     :,TBRES(JGG,NL)                                                       TAV.13    
C                                                                          TAV.14    
*COMDECK WORK                                                              WORK.1     
      COMMON/WORK/IWORK(IDH)                                               WORK.2     
C                                                                          WORK.3     
*COMDECK ZONAV                                                             ZONAV.1     
C     Array ordering in ZONAV and TAV must correspond.                     ZONAV.2     
C                                                                          ZONAV.3     
      COMMON/ZONAV/UBR(JGG,NL),THBR(JGG,NL),TBR(JGG,NL),SFMCR(JGG,NL)      ZONAV.4     
     :,UVBR(JGG,NL),UWBR(JGG,NL),VTBR(JGG,NL),WTBR(JGG,NL),AKZ(JGG,NL)     ZONAV.5     
     :,AKE(JGG,NL),EPFH(JGG,NL),EPFV(JGG,NL),EPDH(JGG,NL),EPDV(JGG,NL)     ZONAV.6     
     :,EPDT(JGG,NL),ENSQ(JGG,NL),QY(JGG,NL),TPWN(JGG,NL),TMTRES(JGG,NL)    ZONAV.7     
     :,WBR(JGG,NL),WBTBR(JGG,NL),VBR(JGG,NL),VBTBR(JGG,NL),QBR(JGG,NL)     ZONAV.8     
     :,RHBR(JGG,NL),VQBR(JGG,NL),WQBR(JGG,NL),HBR(JGG,NL)                  ZONAV.9     
     :,TEMSFBR(JGG,NL),TEMVBR(JGG,NL),TEMWBR(JGG,NL)                       XDTEM3.3     
     :,UUBR(JGG,NL),VVBR(JGG,NL),VWBR(JGG,NL),TTBR(JGG,NL)                 ZONAV.10    
     :,HTBR(JGG,NL),HBTBR(JGG,NL),FUZR(JGG,NL),FUER(JGG,NL)                ZONAV.11    
     :,DUBDMU(JGG,NL),DVBDMU(JGG,NL),DTBDMU(JGG,NL)                        ZONAV.12    
     :,UBRP(JGG,NL),VBRP(JGG,NL),STBP(JGG,NL),THBP(JGG,NL),ABSV(JGG,NL)    ZONAV.13    
     :,DUMNZ(JGG,NL),DUMCN(JGG,NL),DUMCK(JGG,NL),DUMBP(JGG,NL)             ZONAV.14    
C                                                                          ZONAV.15    
*COMDECK ZONAVP                                                            ZONAVP.1     
      COMMON/ZONAVP/UTVDZ(IGG,3),VTVDZ(IGG,3),TTVDZ(IGG,3),QTVDZ(IGG,3)    ZONAVP.2     
     :,TTCRZ(IGG,3),QTCRZ(IGG,3),TTLRZ(IGG,3),QTLRZ(IGG,3),TTRDZ(IGG,3)    ZONAVP.3     
     :,UTBLZ(IGG,3),VTBLZ(IGG,3),TTBLZ(IGG,3),QTBLZ(IGG,3)                 ZONAVP.4     
     :,UTOTZ(IGG,3),VTOTZ(IGG,3),TTOTZ(IGG,3),QTOTZ(IGG,3)                 ZONAVP.5     
     :,CTCRZ(IGG,3),CTLRZ(IGG,3)                                           ZONAVP.6     
C                                                                          ZONAVP.7     
*COMDECK TIMFLX                                                            TIMFLX.1     
      COMMON/TIMFLX/LDAILY,LTIMAV,LTFLUX,LTMAC                             TIMFLX.2     
     :,LTFGR(NTFFLD),LTFPL(NTFFLD),TFFAC(NTFFLD),TFINC(NTFFLD)             TIMFLX.3     
     :,LTFGRZ(NTFFLD),LTFPLZ(NTFFLD),TFFACZ(NTFFLD),TFINCZ(NTFFLD)         TIMFLX.4     
     :,NFIL,NDAYTT,RAV,RPASS,IPER,RFIL                                     TIMFLX.5     
     :,AVER(IGD,6),GV1(IAV,JG),G1(IAV)                                     TIMFLX.6     
      LOGICAL LDAILY,LTIMAV,LTFLUX,LTMAC,LTFGR,LTFPL,LTFGRZ,LTFPLZ         TIMFLX.7     
C                                                                          TIMFLX.8     
*DECK BGFLUX                                                               BGFLUX.1     
      PROGRAM BGFLUX                                                       BGFLUX.2     
C                                                                          BGFLUX.3     
C     ***********************************************************          BGFLUX.4     
C     *                                                         *          BGFLUX.5     
C     * U.K. UNIVERSITIES' GLOBAL ATMOSPHERIC MODELLING PROJECT *          BGFLUX.6     
C     *                                                         *          BGFLUX.7     
C     *   UNIVERSITY OF READING     DEPARTMENT OF METEOROLOGY   *          BGFLUX.8     
C     *                                                         *          BGFLUX.9     
C     *  DIAGNOSTICS PROGRAM FOR INTEGRATIONS OF DRY AND MOIST  *          BGFLUX.10    
C     *      VERSIONS OF READING BAROCLINIC SPECTRAL MODEL      *          BGFLUX.11    
C     *                                                         *          BGFLUX.12    
C     *       IGFLUX 1.1     MIKE BLACKBURN     11.07.2000      *          ANSI2.1     
C     *                                                         *          BGFLUX.14    
C     ***********************************************************          BGFLUX.15    
C                                                                          BGFLUX.16    
*CALL PARAM1                                                               BGFLUX.17    
*CALL PARAM2                                                               BGFLUX.18    
      PARAMETER(IDDAG=NLWG*IGC,IDSURF=5*IGC)                               BGFLUX.19    
C                                                                          ANSI2.2     
C     Include all common blocks in the main program, to avoid SAVEs.       ANSI2.3     
C                                                                          ANSI2.4     
*CALL BATS                                                                 ANSI2.5     
*CALL BLANK                                                                ANSI2.6     
*CALL COMFFT                                                               ANSI2.7     
*CALL COMGEN                                                               ANSI2.8     
*CALL COMGRM                                                               ANSI2.9     
*CALL COMIOC                                                               ANSI2.10    
*CALL COMMSK                                                               ANSI2.11    
*CALL COMPRL                                                               ANSI2.12    
*CALL COMROG                                                               ANSI2.13    
*CALL COMUTF                                                               ANSI2.14    
*CALL DUM                                                                  ANSI2.15    
*CALL GRIDP                                                                ANSI2.16    
*CALL LEGAU                                                                ANSI2.17    
*CALL OUTCON                                                               ANSI2.18    
*CALL PHYS                                                                 ANSI2.19    
*CALL POLYNO                                                               ANSI2.20    
*CALL SERIES                                                               ANSI2.21    
*CALL SPEC                                                                 ANSI2.22    
*CALL SPECTR                                                               ANSI2.23    
*CALL TAV                                                                  ANSI2.24    
*CALL TIMFLX                                                               ANSI2.25    
*CALL WORK                                                                 ANSI2.26    
*CALL ZONAV                                                                ANSI2.27    
*CALL ZONAVP                                                               ANSI2.28    
      REAL DAG(IDDAG)                                                      BGFLUX.32    
      EQUIVALENCE (DAG(1),UG(1))                                           BGFLUX.33    
C                                                                          BGFLUX.34    
 6000 FORMAT(/' ***WARNING: KNTAV-1.NE.NRTAV - TIME AVERAGES INCORRECT'    BGFLUX.35    
     :       ,' KNTAV  NRTAV = ',2I10/)                                    BGFLUX.36    
 6010 FORMAT(/' ***  EXECUTION TIME =',F10.1,' SECONDS ***'                BGFLUX.37    
     :       /' *** TOTAL TIME USED =',F10.1,' SECONDS ***'/)              BGFLUX.38    
 6900 FORMAT( ' ***ABORT IN GFLUX AT DAY',F10.2                            BGFLUX.39    
     :       ,' : DIABATIC HEATING ON RECORD',I5,' NOT JG+2')              BGFLUX.40    
 6908 FORMAT( ' ***ABORT IN GFLUX AT DAY',F10.2                            BUGS4.5     
     :       /' ERROR READING SPECTRAL HEATING: RMTAPE RLTAPE=',2F20.12)   BUGS4.6     
 6910 FORMAT( ' ***ABORT IN GFLUX AT DAY',F10.2                            BGFLUX.41    
     :       /' ERROR READING SPECTRAL DATA : RMTAPE RLTAPE=',2F20.12)     BGFLUX.42    
C                                                                          UCOS.6     
C     ----------------------------------------------------------------     UCOS.7     
C                                                                          UCOS.8     
C     Open unit 6 explicitly as a formatted file.                          ANSI2.29    
C                                                                          ANSI2.30    
      OPEN(6,FORM='FORMATTED')                                             ANSI2.31    
C                                                                          BGFLUX.43    
C     ----------------------------------------------------------------     BGFLUX.44    
C                                                                          BGFLUX.45    
      CALL SECOND(STIME)                                                   BGFLUX.46    
      CALL INITAL                                                          BGFLUX.47    
      IF (DAMP.GT.0.0) CALL HEXRES                                         BGFLUX.48    
      KOUNT=KSTART-KOUNTD                                                  BGFLUX.49    
      KNTAV=0                                                              BGFLUX.50    
      RAV=0.0                                                              TMAV5.35    
C                                                                          BGFLUX.51    
C     ----------------------------------------------------------------     BGFLUX.52    
C                                                                          BGFLUX.53    
C     Main loop over analysis times.                                       BGFLUX.54    
C                                                                          BGFLUX.55    
   10 CONTINUE                                                             BGFLUX.56    
      KOUNT=KOUNT+KOUNTD                                                   BGFLUX.57    
      KNTAV=KNTAV+1                                                        BGFLUX.58    
      RAV=RAV+1.0                                                          TMAV5.36    
      LOUTP=KOUNTP.GT.0 .AND. KOUNT.EQ.KOUNTP*(KOUNT/KOUNTP)               BGFLUX.59    
     :                  .AND. NLAT.GT.0                                    BGFLUX.60    
      LOUTF=KOUNTF.GT.0 .AND. KOUNT.EQ.KOUNTF*(KOUNT/KOUNTF)               BGFLUX.61    
      LOUTA=KOUNTA.GT.0 .AND. KOUNT.EQ.KOUNTA*(KOUNT/KOUNTA)               BGFLUX.62    
      LOUTE=KOUNTE.GT.0 .AND.(KOUNT.EQ.KOUNTE*(KOUNT/KOUNTE)               BGFLUX.63    
     :                        .OR.KOUNT.EQ.KHDAY)                          BGFLUX.64    
      LOUT =LOUTP.OR.LOUTF.OR.LOUTA                                        BGFLUX.65    
      IF (LPC6.AND.(LOUT.OR.LTIMAV)) REWIND NCTHG                          TMAV5.37    
      DO 20 I=1,NGP                                                        BGFLUX.67    
   20 REWIND NCGP(I)                                                       BGFLUX.68    
C                                                                          BGFLUX.69    
C     First process (JG+2) records of parameterisation diagnostics.        BGFLUX.70    
C     PHYSOP uses common SPECTR for workspace.                             BGFLUX.71    
C                                                                          BGFLUX.72    
      IF (KOUNT.GT.KBEGP) THEN                                             BGFLUX.73    
         CALL PHYSOP                                                       BGFLUX.74    
         CALL PHYSEC                                                       BGFLUX.75    
         CALL RCHECK(NCHIST,RNTAPE,KOUNT,TSPD)                             BGFLUX.76    
         READ(NCHIST) RKOUNT,RMTAPE,DAY,RNR,H,RLTAPE                       BUGS4.7     
         IF (NINT(RNR).NE.JG+2) THEN                                       BGFLUX.78    
            WRITE(6,6900) DAY,RNR                                          BGFLUX.79    
            CALL ABORT                                                     BGFLUX.80    
         ENDIF                                                             BGFLUX.81    
         IF (RLTAPE.NE.RMTAPE) THEN                                        BUGS4.8     
            WRITE(6,6908) DAY,RMTAPE,RLTAPE                                BUGS4.9     
            CALL ABORT                                                     BUGS4.10    
         ENDIF                                                             BUGS4.11    
      ELSE                                                                 BGFLUX.82    
         DO 30 I=1,IGB                                                     BGFLUX.83    
   30    H(I)=CMPLX(0.,0.)                                                 BGFLUX.84    
      ENDIF                                                                BGFLUX.85    
C                                                                          BGFLUX.86    
C     Spectral data now processed.                                         BGFLUX.87    
C                                                                          BGFLUX.88    
      CALL RCHECK(NCHIST,RNTAPE,KOUNT,TSPD)                                BGFLUX.89    
      IF (.NOT.LDRY) THEN                                                  BGFLUX.90    
         READ(NCHIST) RKOUNT,RMTAPE,DAY,Z,D,T,Q,SP,RLTAPE                  BGFLUX.91    
      ELSE                                                                 BGFLUX.92    
         READ(NCHIST) RKOUNT,RMTAPE,DAY,Z,D,T,SP,RLTAPE                    BGFLUX.93    
         DO 40 I=1,IGB                                                     BGFLUX.94    
   40    Q(I)=CMPLX(0.,0.)                                                 BGFLUX.95    
      ENDIF                                                                BGFLUX.96    
      IF (RLTAPE.NE.RMTAPE) THEN                                           BGFLUX.97    
         WRITE(6,6910) DAY,RMTAPE,RLTAPE                                   BGFLUX.98    
         CALL ABORT                                                        BGFLUX.99    
      ENDIF                                                                BGFLUX.100   
      KONTM=NINT(RKOUNT)                                                   BGFLUX.101   
C                                                                          BGFLUX.102   
      IF (LPC5) CALL LTEND                                                 BGFLUX.103   
      IF (LOUTE) CALL NSPECT                                               BGFLUX.104   
      IF (NCOEFF.GT.0.AND.LDAILY.AND.LOUTP) CALL OPCOEF                    TMAV5.38    
      IF (.NOT.(LPC2.OR.LPC3.OR.LPC5.OR.LPC6)) GOTO 110                    BUGS5.34    
C                                                                          BGFLUX.107   
C     Loop over latitude for spectral to grid transform.                   BGFLUX.108   
C                                                                          BGFLUX.109   
      IF (JGL.EQ.1) THEN                                                   BGFLUX.110   
         REWIND NCLEG                                                      BGFLUX.111   
         IF (LROG) REWIND NCROGG                                           BGFLUX.112   
      ENDIF                                                                BGFLUX.113   
      JL=1                                                                 BGFLUX.114   
      DO 100 IH=1,JG                                                       BGFLUX.115   
      JH=IH                                                                BGFLUX.116   
      IF (JGL.EQ.1) THEN                                                   BGFLUX.117   
         READ(NCLEG) ALP,DALP,RLP,RDLP                                     BGFLUX.118   
         IF (LROG) READ(NCROGG) GSG                                        BGFLUX.119   
      ENDIF                                                                BGFLUX.120   
      CALL LTI                                                             BGFLUX.121   
      IF (NTWG.EQ.0) GOTO 60                                               BGFLUX.122   
      DO 50 I=1,NTWG                                                       BGFLUX.123   
   50 CALL FFT991(DAG(1+(I-1)*NCRAY*MGPP),WORK,TRIG,IFAX                   BGFLUX.124   
     :           ,1,MGPP,MG,NCRAY,1)                                       BGFLUX.125   
   60 CALL FFT991(DAG(1+NTWG*NCRAY*MGPP),WORK,TRIG,IFAX                    BGFLUX.126   
     :           ,1,MGPP,MG,NRSTWG,1)                                      BGFLUX.127   
      CALL GRMULT                                                          BGFLUX.128   
      IF (.NOT.LINTP2) WRITE(NCGP(1)) SFG                                  BGFLUX.129   
      WRITE(NCGP( 2)) ZG                                                   BGFLUX.130   
      WRITE(NCGP( 3)) DG                                                   BGFLUX.131   
      WRITE(NCGP( 4)) OMG                                                  BGFLUX.132   
      WRITE(NCGP( 5)) UG                                                   BGFLUX.133   
      WRITE(NCGP( 6)) VG                                                   BGFLUX.134   
      WRITE(NCGP( 7)) TG                                                   BGFLUX.135   
      WRITE(NCGP( 8)) GHG                                                  BGFLUX.136   
      WRITE(NCGP( 9)) QG                                                   BGFLUX.137   
      WRITE(NCGP(10)) HG                                                   BGFLUX.138   
      WRITE(NCGP(11)) PLG,PMG,PJG                                          BGFLUX.139   
      WRITE(NCGP(12)) PMSLG                                                BGFLUX.140   
      WRITE(NCGP(13)) FUG                                                  BGFLUX.141   
      WRITE(NCGP(14)) FVG                                                  BGFLUX.142   
      IF (LPC6.AND.(LOUT.OR.LTIMAV)) WRITE(NCTHG) UTHG,VTHG,ERTHG,PTHG     TMAV5.39    
      IF (LTFLUX) CALL TFILT(JH)                                           TMAV5.4     
      JL=JL+JINC                                                           BGFLUX.144   
  100 CONTINUE                                                             BGFLUX.145   
C                                                                          BGFLUX.146   
C     Common SPECTR now free to be used as work space.                     BGFLUX.147   
C                                                                          BGFLUX.148   
      IF (LINTP2) CALL SFGCPR                                              BGFLUX.149   
      IF (LTIMAV) THEN                                                     TMAV5.40    
         IF (LPC6) CALL TIMV(NCTHG)                                        TMAV5.41    
         DO 610 I=1,NGP                                                    TMAV5.42    
         CALL TIMV(NCGP(I))                                                TMAV5.43    
  610    CONTINUE                                                          TMAV5.44    
      ENDIF                                                                TMAV5.45    
      IF (LPC3.OR.LPC5) CALL FLUX                                          BGFLUX.150   
      IF (LPC5) CALL GDIAG                                                 BGFLUX.151   
      IF (LDAILY.AND.LOUT) THEN                                            TMAV5.46    
         CALL INIMSK                                                       BGFLUX.153   
         IF (LPC2) CALL OPGRID                                             BGFLUX.154   
         IF (LPC6) CALL OPERTEL                                            BGFLUX.155   
         IF (LPC3) CALL FLXPRC                                             BGFLUX.156   
      ENDIF                                                                BGFLUX.157   
C                                                                          BUGS5.35    
  110 CONTINUE                                                             BUGS5.36    
C                                                                          BGFLUX.158   
      IF (KOUNT.LT.KEND) GOTO 10                                           BGFLUX.159   
C                                                                          BGFLUX.160   
C     ----------------------------------------------------------------     BGFLUX.161   
C                                                                          BGFLUX.162   
C     Time series of global diagnostics and time averaged sections.        BGFLUX.163   
C                                                                          BGFLUX.164   
      IF (NRTAV.GT.0.AND.KNTAV-1.NE.NRTAV) THEN                            BGFLUX.165   
         WRITE(6,6000)                                                     BGFLUX.166   
         WRITE(NCFICH,6000)                                                BGFLUX.167   
      ENDIF                                                                BGFLUX.168   
      KOUNT=-999                                                           BGFLUX.169   
      DAY=-999.                                                            BGFLUX.170   
      LOUTP=KOUNTP.GT.0                                                    BGFLUX.171   
      LOUTF=KOUNTF.GT.0                                                    BGFLUX.172   
      LOUTA=KOUNTA.GT.0                                                    BGFLUX.173   
      LOUT =LOUTP.OR.LOUTF.OR.LOUTA                                        BGFLUX.174   
      IF (LPC5) CALL GDIAG                                                 BGFLUX.175   
      IF (LPC3.AND.LTAV.AND.LOUT) CALL FLXPRC                              BGFLUX.176   
      IF (KEND.GT.KBEGP) THEN                                              BGFLUX.177   
         IF (LPC9) CALL PHYSAV                                             BGFLUX.178   
         IF (LPC8.AND.LTAV.AND.LOUT) CALL PHYSEC                           BGFLUX.179   
      ENDIF                                                                BGFLUX.180   
C                                                                          TMAV5.5     
C     Time averaged transient fluxes.                                      TMAV5.6     
C                                                                          TMAV5.7     
      IF (LTFLUX) THEN                                                     TMAV5.8     
         CALL TFLUXE                                                       TMAV5.9     
         CALL TFPLOT                                                       TMAV5.10    
      ENDIF                                                                TMAV5.11    
C                                                                          TMAV5.47    
C     Time averaged 3D fields.                                             TMAV5.48    
C                                                                          TMAV5.49    
      IF (LTIMAV) THEN                                                     TMAV5.50    
         IF (LPC6) CALL TRANS(NCTHG)                                       TMAV5.51    
         DO 620 I=1,NGP                                                    TMAV5.52    
         CALL TRANS(NCGP(I))                                               TMAV5.53    
  620    CONTINUE                                                          TMAV5.54    
         IF (LPC2) CALL OPGRID                                             TMAV5.55    
         IF (LPC6) CALL OPERTEL                                            TMAV5.56    
      ENDIF                                                                TMAV5.57    
C                                                                          BGFLUX.181   
C     Copy all KE spectra data from scratch files to channel NCPLOT(1)     BGFLUX.182   
C     for subsequent plotting job.                                         BGFLUX.183   
C                                                                          BGFLUX.184   
      IF (KOUNTE.GT.0) CALL NSPECT                                         KSPEC2.2     
      IF (LSPPLT.OR.LENCOP.OR.LPHCOP) REWIND NCPLOT(1)                     BGFLUX.186   
C                                                                          BGFLUX.187   
C     Close data transfer file (UTF).                                      BUGS4.12    
C                                                                          BGFLUX.189   
      IF (LOUTA) THEN                                                      UTF14.8     
         CALL U14WE(NPCA)                                                  UTF14.9     
         CLOSE(NPCA)                                                       UTF14.10    
      ENDIF                                                                UTF14.11    
C                                                                          BGFLUX.194   
      IF (JGL.EQ.1) THEN                                                   BGFLUX.195   
  210    CONTINUE                                                          BGFLUX.230   
      ENDIF                                                                BGFLUX.231   
C                                                                          BGFLUX.232   
C     Write CPU timing to output and fiche channels.                       BGFLUX.233   
C                                                                          BGFLUX.234   
      CALL SECOND(FTIME)                                                   BGFLUX.235   
      ETIME=FTIME-STIME                                                    BGFLUX.236   
      WRITE(6,6010) ETIME,FTIME                                            BGFLUX.237   
      WRITE(NCFICH,6010) ETIME,FTIME                                       BGFLUX.238   
C                                                                          BGFLUX.239   
      STOP                                                                 BGFLUX.240   
      END                                                                  BGFLUX.241   
C     ****************************************************************     BGFLUX.242   
*DECK INITAL                                                               INITAL.1     
      SUBROUTINE INITAL                                                    INITAL.2     
C                                                                          INITAL.3     
*CALL PARAM1                                                               INITAL.4     
*CALL PARAM2                                                               INITAL.5     
*CALL BATS                                                                 INITAL.6     
*CALL BLANK                                                                INITAL.7     
*CALL COMFFT                                                               INITAL.8     
*CALL COMIOC                                                               INITAL.9     
*CALL COMMSK                                                               INITAL.10    
*CALL COMPRL                                                               INITAL.11    
*CALL COMROG                                                               INITAL.12    
*CALL LEGAU                                                                INITAL.14    
*CALL OUTCON                                                               INITAL.15    
*CALL PHYS                                                                 INITAL.16    
*CALL POLYNO                                                               INITAL.17    
*CALL SPEC                                                                 INITAL.18    
*CALL SPECTR                                                               INITAL.19    
*CALL TIMFLX                                                               TMAV5.12    
*CALL TAV                                                                  INITAL.20    
      CHARACTER*8 NAME(2)                                                  SUNMOD.76    
      REAL HEIGHT(NL),CR(NL),CI(NL),TBM1(NL2)                              INITAL.22    
      REAL DDZT(IDDZ)                                                      INITAL.23    
      EQUIVALENCE (DDZT(1),UBT(1,1))                                       INITAL.24    
      CHARACTER LCENTR*3                                                   INITAL.25    
C                                                                          INITAL.91    
C     Remaining initial data.                                              INITAL.92    
C                                                                          INITAL.93    
      DATA SECHR/3600./                                                    INITAL.94    
      DATA LCENTR/'RAL'/                                                   INITAL.95    
C                                                                          INITAL.96    
*CALL INPB                                                                 INITAL.97    
*CALL INTM                                                                 TMAV5.24    
*CALL INPHYS                                                               INITAL.98    
 6000 FORMAT(///' **** RNTAPE',F9.3,' ****',15X                            INITAL.99    
     :         ,' **** IGFLUX 1.1 DIAGNOSTICS ****'                        ANSI2.32    
     :        //' INTEGRATION WITH ',I3                                    INITAL.101   
     :         ,' LEVELS IN THE VERTICAL (NL=',I3,')'                      INITAL.102   
     :        //' JAGGED TRAPEZOIDAL/TRIANGULAR TRUNCATION AT TOTAL'       INITAL.103   
     :         ,' WAVENO.',I3,' AND ZONAL WAVENO.',I3                      INITAL.104   
     :         ,' (NN=',I3,' MM=',I3,')')                                  INITAL.105   
 6010 FORMAT(/' NHEM=',I1,' GLOBAL DOMAIN: BOTH EVEN AND ODD'              INITAL.106   
     :       ,' COEFFICIENTS INCLUDED')                                    INITAL.107   
 6020 FORMAT(/' NHEM=',I1,' HEMISPHERIC DOMAIN: ONLY EVEN DIVERGENCE,'     INITAL.108   
     :       ,' TEMPERATURE AND SURFACE PRESSURE'                          INITAL.109   
     :       /' AND ODD VORTICITY COEFFICIENTS INCLUDED')                  INITAL.110   
 6030 FORMAT(/I3,'-FOLD SYMMETRY IN LONGITUDE IMPOSED AND ONLY 1 /'        INITAL.111   
     :       ,I2,' OF THE DOMAIN USED (MOCT=',I2,')')                      INITAL.112   
 6040 FORMAT(/' NON LINEAR TERMS EVALUATED ON GRID OF',I3                  INITAL.113   
     :       ,' GAUSSIAN LATITUDES AND',I4                                 INITAL.114   
     :       ,' EVENLY SPACED LONGITUDES (JG=',I3,' MG=',I3,')')           INITAL.115   
 6050 FORMAT(/' ECMWF ANGULAR MOMENTUM CONSERVING INTEGRATION')            INITAL.116   
 6060 FORMAT(/' DEL',I2,' DISSIPATION WITH COEFFICIENT',1PE12.5,0P         INITAL.117   
     :       ,' M',I1,'/S'                                                 INITAL.118   
     :       /' E-FOLDING TIME FOR SMALLEST RESOLVED SCALE IS ',F5.3       INITAL.119   
     :       ,' SIDEREAL DAYS')                                            INITAL.120   
 6070 FORMAT(/' NO DISSIPATION')                                           INITAL.121   
 6080 FORMAT(/' RESTORATION ON A TIME SCALE OF',F4.1,' DAYS')              INITAL.122   
 6090 FORMAT(/' NO RESTORATION')                                           INITAL.123   
 6100 FORMAT( ' NAME IS ',2A8)                                             INITAL.124   
 6110 FORMAT(/' GAUSSIAN LATITUDES (DEG)'/(20F6.1))                        INITAL.125   
 6120 FORMAT(/' SIGMA AT HALF LEVELS'/(15F7.4))                            INITAL.126   
 6130 FORMAT(/' SIGMA AT FULL LEVELS'/(15F7.4))                            INITAL.127   
 6140 FORMAT(/' BASIC STATE HEIGHTS (KM)'/(15F7.3))                        INITAL.128   
 6150 FORMAT(/' GRAVITY WAVE SPEEDS (M/S)'/(15F7.2))                       INITAL.129   
 6200 FORMAT(/' DRY HISTORY FILE PROCESSED : NO PARAMETERISATIONS')        INITAL.130   
 6210 FORMAT(/' PARAMETERISATION DIAGNOSTICS INCLUDED FOR :')              INITAL.131   
 6220 FORMAT(/' NO PARAMETERISATION DIAGNOSTICS INCLUDED')                 INITAL.132   
 6230 FORMAT( ' SURFACE FLUXES : CD =',F10.4)                              INITAL.133   
 6240 FORMAT( ' DRY AND MOIST CONVECTION')                                 INITAL.134   
 6250 FORMAT( ' LARGE-SCALE CONDENSATION TO SATURATION IN TIMESTEP')       INITAL.135   
 6260 FORMAT( ' RADIATION : UNIFORM COOLING BELOW 200MB')                  INITAL.136   
 6270 FORMAT( ' VERTICAL DIFFUSION INCLUDING FOR MOMENTUM AKVV=',F8.2)     INITAL.137   
 6280 FORMAT(///' PATH NAMES FOR DIRECTORIES ARE:'/' TEMP    DIR : ',A     UCOS.19    
     :         /' HOME    DIR : ',A/' CURRENT DIR : ',A///)                UCOS.20    
 6900 FORMAT(/' ***ABORT IN INITAL : PADDING ARRAY IN SPECTR IS TOO'       PADLEN.7     
     :       ,' SHORT : INCREASE FROM',I8,' TO',I8)                        PADLEN.8     
 6901 FORMAT(/' ***CAUTION : PADDING ARRAY IN SPECTR IS LONGER THAN'       PADLEN.9     
     :       ,' NECESSARY : CAN REDUCE FROM',I8,' TO',I8)                  PADLEN.10    
 6913 FORMAT( ' ***CHECK CALCULATION OF PARAMETERS AND TOP OF INITAL'      PADLEN.11    
     :       /' SPECTRAL LENGTH ILS1 =',I8                                 PADLEN.12    
     :       /' EQUIVALENCED ARRAY LENGTHS =',10I8)                        PADLEN.13    
 6914 FORMAT(/' PARAM  : MAX EQUIV LENGTH =',I8,' : PAD LENGTH =',I8       PADLEN.14    
     :       /' INITAL : MAX EQUIV LENGTH =',I8,' : PAD LENGTH =',I8/)     PADLEN.15    
 6902 FORMAT(/' ***ABORT IN INITAL: JGL MUST BE EITHER 1 OR JG')           INITAL.145   
 6903 FORMAT(/' ***ABORT IN INITAL: KOUNTD MUST BE NON-ZERO')              INITAL.146   
 6904 FORMAT(/' ***ABORT IN INITAL: KOUNTP MUST BE MULTIPLE OF KOUNTD')    INITAL.147   
 6905 FORMAT(/' ***ABORT IN INITAL: KOUNTF MUST BE MULTIPLE OF KOUNTD')    INITAL.148   
 6906 FORMAT(/' ***ABORT IN INITAL: KOUNTA MUST BE MULTIPLE OF KOUNTD')    INITAL.149   
 6907 FORMAT(/' ***ABORT IN INITAL: KOUNTE MUST BE MULTIPLE OF KOUNTD')    INITAL.150   
 6908 FORMAT(/' ***ABORT IN INITAL: NLAT VALUE INVALID')                   INITAL.151   
 6909 FORMAT(/' ***ABORT IN INITAL: NLONG VALUE INVALID')                  INITAL.152   
 6910 FORMAT(/' ***ABORT IN INITAL: NCOEFF VALUE INVALID')                 INITAL.153   
 6911 FORMAT(/' ***WARNING: ATTEMPT TO CONTOUR ISENTROPIC WINDS:'          INITAL.154   
     :       ,' LTHPL(1) AND LTHPL(2) SWITCHED OFF')                       ANSI2.33    
 6912 FORMAT(/' ***ABORT IN INITAL: PARAMETER NWJ2 INCONSISTENT WITH'      INITAL.156   
     :       ,' RESOLUTION PARAMETERS NN AND MM: NWJ2, NWJC =',2I5)        ANSI2.34    
C                                                                          ANSI2.35    
C     Default values for I/O channels.                                     ANSI2.36    
C                                                                          ANSI2.37    
      NCFICH=3                                                             ANSI2.38    
      NCHIST=10                                                            ANSI2.39    
      NCREST=13                                                            ANSI2.40    
      NCSURF=14                                                            ANSI2.41    
      NCROGG=15                                                            ANSI2.42    
      NCROGS=16                                                            ANSI2.43    
      NCSTH=17                                                             ANSI2.44    
      NCST4(1)=18                                                          ANSI2.45    
      NCST4(2)=19                                                          ANSI2.46    
      NCPLOT(1)=22                                                         ANSI2.47    
      NCPLOT(2)=21                                                         ANSI2.48    
      NCPLOT(3)=20                                                         ANSI2.49    
      NCLEG=25                                                             ANSI2.50    
      NCGEN=38                                                             ANSI2.51    
      NCGDG=39                                                             ANSI2.52    
      NCTHG=40                                                             ANSI2.53    
      DO 1010 I=1,NGP                                                      ANSI2.54    
         NCGP(I)=40+I                                                      ANSI2.55    
 1010 CONTINUE                                                             ANSI2.56    
      NCTFI=83                                                             ANSI2.57    
      NCTFO=91                                                             ANSI2.58    
      NCTADD=28                                                            ANSI2.59    
C                                                                          ANSI2.60    
C     Default values for namelist INPB.                                    ANSI2.61    
C                                                                          ANSI2.62    
      LSSD=.FALSE.                                                         ANSI2.63    
C                                                                          ANSI2.64    
      GA=9.81                                                              ANSI2.65    
      WW=7.292E-5                                                          ANSI2.66    
      RADEA=6.371E6                                                        ANSI2.67    
      P0=1.0E5                                                             ANSI2.68    
      AKAP=0.286                                                           ANSI2.69    
      RD=287.0                                                             ANSI2.70    
      RV=461.51                                                            ANSI2.71    
      CLATNT=2.5E6                                                         ANSI2.72    
C                                                                          ANSI2.73    
      NDEL=8                                                               ANSI2.74    
      TDISS=0.125       ! Not in common.                                   ANSI2.75    
      RESTIM=0.0        ! Not in common.                                   ANSI2.76    
      DO 1020 K=1,NL                                                       ANSI2.77    
         DRAG(K)=0.0                                                       ANSI2.78    
 1020 CONTINUE                                                             ANSI2.79    
C                                                                          ANSI2.80    
      NPC1=3                                                               ANSI2.81    
      NPC2=3                                                               ANSI2.82    
      NPC3=3                                                               ANSI2.83    
      NPC4=3                                                               ANSI2.84    
      NPC5=3                                                               ANSI2.85    
      NPC6=3                                                               ANSI2.86    
      NPC7=3                                                               ANSI2.87    
      NPC8=3                                                               ANSI2.88    
      NPC9=3                                                               ANSI2.89    
      NPCA=65                                                              ANSI2.90    
      LPC2=.FALSE.                                                         ANSI2.91    
      LPC3=.TRUE.                                                          ANSI2.92    
      LPC5=.TRUE.                                                          ANSI2.93    
      LPC6=.FALSE.                                                         ANSI2.94    
      LPC7=.FALSE.                                                         ANSI2.95    
      LPC8=.TRUE.                                                          ANSI2.96    
      LPC9=.TRUE.                                                          ANSI2.97    
C                                                                          ANSI2.98    
      NCOEFF=NN                                                            ANSI2.99    
      NLAT=JG                                                              ANSI2.100   
      NLONG=MG                                                             ANSI2.101   
C                                                                          ANSI2.102   
      DO 1030 K=1,NL                                                       ANSI2.103   
         LSPO(K)=.FALSE.                                                   ANSI2.104   
         LGPO(K)=.FALSE.                                                   ANSI2.105   
         LGFO(K)=.FALSE.                                                   ANSI2.106   
 1030 CONTINUE                                                             ANSI2.107   
      LSGEDY=.FALSE.                                                       ANSI2.108   
      LSGGRZ=.TRUE.                                                        ANSI2.109   
      LSGPLZ=.FALSE.                                                       ANSI2.110   
C                                                                          ANSI2.111   
      DO 1040 I=1,NSG                                                      ANSI2.112   
         LSGGR(I)=.TRUE.                                                   ANSI2.113   
         LSGPL(I)=.TRUE.                                                   ANSI2.114   
         SGFAC(I)=0.1                                                      ANSI2.115   
         SGINC(I)=-0.1                                                     ANSI2.116   
 1040 CONTINUE                                                             ANSI2.117   
      LSGGR(11)=.FALSE.                                                    ANSI2.118   
      LSGPL(3)=.FALSE.                                                     ANSI2.119   
      LSGPL(5)=.FALSE.                                                     ANSI2.120   
      LSGPL(6)=.FALSE.                                                     ANSI2.121   
      LSGPL(8)=.FALSE.                                                     ANSI2.122   
      LSGPL(11)=.FALSE.                                                    ANSI2.123   
      SGFAC(1)=1.0E6                                                       ANSI2.124   
      SGFAC(2)=1.0E-6                                                      ANSI2.125   
      SGFAC(3)=1.0E-7                                                      ANSI2.126   
      SGFAC(8)=10.0                                                        ANSI2.127   
      SGFAC(11)=1.0                                                        ANSI2.128   
      SGINC(1)=1.0E7                                                       ANSI2.129   
      SGINC(2)=1.0E-5                                                      ANSI2.130   
      SGINC(3)=1.0E-6                                                      ANSI2.131   
      SGINC(4)=1.0                                                         ANSI2.132   
      SGINC(5)=10.0                                                        ANSI2.133   
      SGINC(6)=10.0                                                        ANSI2.134   
      SGINC(7)=4.0                                                         ANSI2.135   
      SGINC(8)=200.0                                                       ANSI2.136   
      SGINC(9)=1.0                                                         ANSI2.137   
      SGINC(10)=1.0                                                        ANSI2.138   
      SGINC(11)=20.0                                                       ANSI2.139   
      SGINC(12)=4.0                                                        ANSI2.140   
C                                                                          ANSI2.141   
      DO 1050 I=1,NXD                                                      ANSI2.142   
         LXDGR(I)=.TRUE.                                                   ANSI2.143   
         LXDPL(I)=.TRUE.                                                   ANSI2.144   
         XDFAC(I)=0.1                                                      ANSI2.145   
         XDINC(I)=-0.1                                                     ANSI2.146   
 1050 CONTINUE                                                             ANSI2.147   
      LXDPL(11)=.FALSE.                                                    ANSI2.148   
      LXDPL(12)=.FALSE.                                                    ANSI2.149   
      LXDPL(13)=.FALSE.                                                    ANSI2.150   
      LXDPL(14)=.FALSE.                                                    ANSI2.151   
      LXDPL(21)=.FALSE.                                                    ANSI2.152   
      LXDPL(23)=.FALSE.                                                    ANSI2.153   
      XDFAC(4)=1.0E9                                                       ANSI2.154   
      XDFAC(5)=1.0                                                         ANSI2.155   
      XDFAC(7)=1.0                                                         ANSI2.156   
      XDFAC(9)=10.0                                                        ANSI2.157   
      XDFAC(10)=10.0                                                       ANSI2.158   
      XDFAC(11)=1.0E14                                                     ANSI2.159   
      XDFAC(12)=1.0E19                                                     ANSI2.160   
      XDFAC(13)=1.0E14                                                     ANSI2.161   
      XDFAC(14)=1.0E14                                                     ANSI2.162   
      XDFAC(15)=1.0E14                                                     ANSI2.163   
      XDFAC(16)=1.0E-5                                                     ANSI2.164   
      XDFAC(17)=1.0E-12                                                    ANSI2.165   
      XDFAC(21)=1.0                                                        ANSI2.166   
      XDFAC(22)=0.01                                                       ANSI2.167   
      XDFAC(23)=1.0                                                        ANSI2.168   
      XDFAC(25)=1.0                                                        ANSI2.169   
      XDFAC(29)=1.0E9                                                      ANSI2.170   
      XDINC(1)=5.0                                                         ANSI2.171   
      XDINC(2)=5.0                                                         ANSI2.172   
      XDINC(3)=5.0                                                         ANSI2.173   
      XDINC(11)=1.0E14                                                     ANSI2.174   
      XDINC(12)=1.0E14                                                     ANSI2.175   
      XDINC(13)=0.0                                                        ANSI2.176   
      XDINC(14)=0.0                                                        ANSI2.177   
      XDINC(15)=4.0E15                                                     ANSI2.178   
      XDINC(16)=5.0E-5                                                     ANSI2.179   
      XDINC(17)=2.0E-11                                                    ANSI2.180   
      XDINC(18)=2.0                                                        ANSI2.181   
      XDINC(19)=1.0                                                        ANSI2.182   
      XDINC(24)=1.0                                                        ANSI2.183   
      XDINC(25)=10.0                                                       ANSI2.184   
      XDINC(28)=0.5                                                        ANSI2.185   
C                                                                          ANSI2.186   
      LSPPLT=.FALSE.                                                       ANSI2.187   
      LENCOP=.FALSE.                                                       ANSI2.188   
C                                                                          ANSI2.189   
      THSURD(1)=350.0                                                      ANSI2.190   
      THSURD(2)=330.0                                                      ANSI2.191   
      THSURD(3)=310.0                                                      ANSI2.192   
      THSURD(4)=295.0                                                      ANSI2.193   
      THSURD(5)=280.0                                                      ANSI2.194   
      CPHASE=0.0                                                           ANSI2.195   
      DO 1060 I=1,NTH                                                      ANSI2.196   
         LTHGR(I)=.FALSE.                                                  ANSI2.197   
         LTHPL(I)=.FALSE.                                                  ANSI2.198   
         THFAC(I)=0.1                                                      ANSI2.199   
         THINC(I)=0.0                                                      ANSI2.200   
 1060 CONTINUE                                                             ANSI2.201   
      THFAC(4)=1.0                                                         ANSI2.202   
      THINC(1)=10.0                                                        ANSI2.203   
      THINC(2)=10.0                                                        ANSI2.204   
      THINC(3)=0.5                                                         ANSI2.205   
      THINC(4)=50.0                                                        ANSI2.206   
C                                                                          ANSI2.207   
      DO 1070 I=1,NPH                                                      ANSI2.208   
         LPHGR(I)=.FALSE.                                                  ANSI2.209   
         LPHPL(I)=.FALSE.                                                  ANSI2.210   
         PHFAC(I)=0.1                                                      ANSI2.211   
         PHINC(I)=5.0                                                      ANSI2.212   
 1070 CONTINUE                                                             ANSI2.213   
      PHFAC(1)=0.01                                                        ANSI2.214   
      PHFAC(2)=1.0                                                         ANSI2.215   
      PHFAC(3)=1.0                                                         ANSI2.216   
      PHINC(1)=0.1                                                         ANSI2.217   
      PHINC(2)=25.0                                                        ANSI2.218   
      PHINC(3)=25.0                                                        ANSI2.219   
      LPHCOP=.FALSE.                                                       ANSI2.220   
C                                                                          ANSI2.221   
      DO 1080 I=1,NXP                                                      ANSI2.222   
         LXPGR(I)=.TRUE.                                                   ANSI2.223   
         LXPPL(I)=.FALSE.                                                  ANSI2.224   
         XPFAC(I)=0.1                                                      ANSI2.225   
         XPINC(I)=0.5                                                      ANSI2.226   
 1080 CONTINUE                                                             ANSI2.227   
      LXPPL(14)=.TRUE.                                                     ANSI2.228   
      LXPPL(15)=.TRUE.                                                     ANSI2.229   
      LXPPL(16)=.TRUE.                                                     ANSI2.230   
      LXPPL(17)=.TRUE.                                                     ANSI2.231   
      XPFAC(18)=1.0                                                        ANSI2.232   
      XPFAC(19)=1.0                                                        ANSI2.233   
      XPINC(1)=5.0                                                         ANSI2.234   
      XPINC(2)=5.0                                                         ANSI2.235   
      XPINC(10)=5.0                                                        ANSI2.236   
      XPINC(11)=5.0                                                        ANSI2.237   
      XPINC(14)=5.0                                                        ANSI2.238   
      XPINC(15)=5.0                                                        ANSI2.239   
      XPINC(18)=0.0                                                        ANSI2.240   
      XPINC(19)=0.0                                                        ANSI2.241   
C                                                                          ANSI2.242   
      LROG=.FALSE.                                                         ANSI2.243   
      LROGGR=.FALSE.                                                       ANSI2.244   
      LROGPL=.FALSE.                                                       ANSI2.245   
      ROGFAC=10.0                                                          ANSI2.246   
      ROGINC=200.0                                                         ANSI2.247   
C                                                                          ANSI2.248   
      LINTP2=.FALSE.                                                       ANSI2.249   
      LINTP3=.TRUE.                                                        ANSI2.250   
      LXTRP2=.TRUE.                                                        ANSI2.251   
      LXTRP3=.TRUE.                                                        ANSI2.252   
      NLPR=0                                                               ANSI2.253   
      DO 1090 K=1,NL                                                       ANSI2.254   
         PLOUT(K)=0.0                                                      ANSI2.255   
 1090 CONTINUE                                                             ANSI2.256   
      LMSK2=.FALSE.                                                        ANSI2.257   
      LMSK3=.FALSE.                                                        ANSI2.258   
C                                                                          ANSI2.259   
      IASCII=2                                                             ANSI2.260   
      IZGTYP=4                                                             ANSI2.261   
      NAME(1)='NO-ONE  '    ! Not in common.                               ANSI2.262   
      NAME(2)='        '    ! Not in common.                               ANSI2.263   
C                                                                          ANSI2.264   
C     Default values for namelist INTM.                                    ANSI2.265   
C                                                                          ANSI2.266   
      LDAILY=.FALSE.                                                       ANSI2.267   
      LTIMAV=.TRUE.                                                        ANSI2.268   
      LTFLUX=.FALSE.                                                       ANSI2.269   
      LTMAC=.FALSE.                                                        ANSI2.270   
      DO 1100 I=1,NTFFLD                                                   ANSI2.271   
         LTFGR(I)=.FALSE.                                                  ANSI2.272   
         LTFPL(I)=.FALSE.                                                  ANSI2.273   
         TFFAC(I)=1.0                                                      ANSI2.274   
         TFINC(I)=-0.1                                                     ANSI2.275   
         LTFGRZ(I)=.FALSE.                                                 ANSI2.276   
         LTFPLZ(I)=.TRUE.                                                  ANSI2.277   
         TFFACZ(I)=1.0                                                     ANSI2.278   
         TFINCZ(I)=-0.1                                                    ANSI2.279   
 1100 CONTINUE                                                             ANSI2.280   
C                                                                          ANSI2.281   
C     Default values for namelist INPHYS.                                  ANSI2.282   
C                                                                          ANSI2.283   
      BEGDP=0.0                                                            ANSI2.284   
      LDRY=.FALSE.                                                         ANSI2.285   
      LBL=.FALSE.                                                          ANSI2.286   
      LVD=.FALSE.                                                          ANSI2.287   
      LCR=.FALSE.                                                          ANSI2.288   
      LLR=.FALSE.                                                          ANSI2.289   
      LRD=.FALSE.                                                          ANSI2.290   
      CD=0.001                                                             ANSI2.291   
      AKVV=1.0                                                             ANSI2.292   
C                                                                          INITAL.158   
C     Check supplied parameters.                                           INITAL.159   
C     Any changes to spectral arrays or equivalenced grid point arrays     PADLEN.16    
C     should be reflected both here and in the parameter statement         PADLEN.17    
C     where the spectral padding array length is calculated.               PADLEN.18    
C     This code checks the necessarily complicated parameter calcs.        PADLEN.19    
C                                                                          PADLEN.20    
      ILGMX=MAX0(ILG2,ILG6,ILG7)                                           PADLEN.21    
      IPDMX=MAX0(ILGMX-ILS1,2)                                             PADLEN.22    
      IF (ISPAD.LT.IPDMX) THEN                                             PADLEN.23    
         WRITE(6,6900) ISPAD,IPDMX                                         PADLEN.24    
         WRITE(6,6913) ILS1,ILG2,ILG6,ILG7                                 PADLEN.25    
         WRITE(6,6914) ILGB,ISPAD,ILGMX,IPDMX                              PADLEN.26    
         CALL ABORT                                                        PADLEN.27    
      ELSE IF (ISPAD.GT.IPDMX) THEN                                        PADLEN.28    
         WRITE(6,6901) ISPAD,IPDMX                                         PADLEN.29    
         WRITE(6,6913) ILS1,ILG2,ILG6,ILG7                                 PADLEN.30    
         WRITE(6,6914) ILGB,ISPAD,ILGMX,IPDMX                              PADLEN.31    
      ENDIF                                                                PADLEN.32    
C                                                                          PADLEN.33    
      IF (JGL.NE.1.AND.JGL.NE.JG) THEN                                     INITAL.173   
      WRITE(6,6902)                                                        INITAL.174   
      CALL ABORT                                                           INITAL.175   
      ENDIF                                                                INITAL.176   
C                                                                          INITAL.177   
C     Derive spectral constants from resolution parameters.                INITAL.178   
C                                                                          INITAL.179   
      MF=MM-1                                                              INITAL.180   
      MFP=MM                                                               INITAL.181   
      MFPP=MM+1                                                            INITAL.182   
      NF=NN-1                                                              INITAL.183   
      NFP=NN                                                               INITAL.184   
      NFPP=NN+1                                                            INITAL.185   
C                                                                          UCOS.21    
C     Read character strings containing absolute path names                UCOS.22    
C     for temporary, home and current directories.  Stored in COMIOL.      UCOS.23    
C                                                                          UCOS.24    
      CBLANK=' '                                                           UCOS.25    
      WRITE(CPTHTD,'(80A1)') (CBLANK,I=1,80)                               UCOS.26    
      WRITE(CPTHHD,'(80A1)') (CBLANK,I=1,80)                               UCOS.27    
      WRITE(CPTHWD,'(80A1)') (CBLANK,I=1,80)                               UCOS.28    
      READ(5,'(A)') CPTHTD                                                 UCOS.29    
      READ(5,'(A)') CPTHHD                                                 UCOS.30    
      READ(5,'(A)') CPTHWD                                                 UCOS.31    
      NLENTD=LENSIG(CPTHTD)                                                UCOS.32    
      NLENHD=LENSIG(CPTHHD)                                                UCOS.33    
      NLENWD=LENSIG(CPTHWD)                                                UCOS.34    
      WRITE(6,6280) CPTHTD(1:NLENTD),CPTHHD(1:NLENHD),CPTHWD(1:NLENWD)     UCOS.35    
C                                                                          INITAL.186   
C     Read namelists INPB & INPHYS.                                        INITAL.187   
C     Defaults set in data statements above.                               INITAL.188   
C                                                                          INITAL.189   
      READ(5,INPB)                                                         INITAL.190   
      READ(5,INTM)                                                         TMAV5.25    
      READ(5,INPHYS)                                                       INITAL.191   
C                                                                          INITAL.192   
C     Remaining dimensional factors, fundamental and derived constants.    INITAL.193   
C                                                                          INITAL.194   
      CMBHR=.01*WW*SECHR*P0                                                INITAL.195   
      CV=RADEA*WW                                                          INITAL.196   
      CG=CV*CV                                                             INITAL.197   
      CT=CG/RD                                                             INITAL.198   
      CQ=1000.                                                             INITAL.199   
      CTT=PI2*CT                                                           INITAL.200   
      CEP=PI2*RADEA*RADEA*CG/GA                                            INITAL.201   
      CERT=CT*WW*GA/P0                                                     INITAL.202   
C                                                                          INITAL.203   
      CPD=RD/AKAP                                                          INITAL.204   
      EZ=1./SQRT(.375)                                                     INITAL.205   
      XLAPSE=.0065*RD/GA                                                   INITAL.206   
C                                                                          INITAL.207   
      NW=1+MF/MOCT                                                         INITAL.208   
      RMG=1./MG                                                            INITAL.209   
C                                                                          INITAL.210   
C     Print description of run.                                            INITAL.211   
C                                                                          INITAL.212   
      WRITE(6,6000) RNTAPE,NL,NL,NN,MF,NN,MM                               INITAL.213   
      IF (NHEM.EQ.2) WRITE(6,6010)NHEM                                     INITAL.214   
      IF (NHEM.EQ.1) WRITE(6,6020)NHEM                                     INITAL.215   
      WRITE(6,6030) MOCT,MOCT,MOCT                                         INITAL.216   
      WRITE(6,6040) JG,MG,JG,MG                                            INITAL.217   
      WRITE(6,6050)                                                        INITAL.218   
C                                                                          INITAL.219   
C     Constants for horizontal diffusion and linear restoration.           INITAL.220   
C                                                                          INITAL.221   
      IF (TDISS.GT.0.) THEN                                                INITAL.222   
         AKK=WW*(RADEA**NDEL)/(PI2*TDISS*((NN*(NN+1))**REAL(NDEL/2)))      BUGS2.2     
         WRITE(6,6060) NDEL,AKK,NDEL,TDISS                                 INITAL.224   
         AKK=AKK*CG*P0/(GA*(RADEA**NDEL))                                  INITAL.225   
      ELSE                                                                 INITAL.226   
         AKK=0.                                                            INITAL.227   
         WRITE(6,6070)                                                     INITAL.228   
      ENDIF                                                                INITAL.229   
      NDELH=NDEL/2                                                         INITAL.230   
      NDELHM=NDELH-1                                                       INITAL.231   
C                                                                          INITAL.232   
      IF (RESTIM.GT.0.) THEN                                               INITAL.233   
         WRITE(6,6080) RESTIM                                              INITAL.234   
         DAMP=WW*CG*P0/(GA*RESTIM*PI2)                                     INITAL.235   
         READ(NCREST) ZRES,DRES,TRES                                       INITAL.236   
      ELSE                                                                 INITAL.237   
         WRITE(6,6090)                                                     INITAL.238   
         DAMP=0.                                                           INITAL.239   
         DO 10 I=1,IGN                                                     INITAL.240   
         ZRES(I)=0.                                                        INITAL.241   
         DRES(I)=0.                                                        INITAL.242   
         TRES(I)=0.                                                        INITAL.243   
   10    CONTINUE                                                          INITAL.244   
      ENDIF                                                                INITAL.245   
      DO 20 L=1,NL                                                         INITAL.246   
      DO 20 I=1,JGG                                                        INITAL.247   
      TBRES(I,L)=0.                                                        INITAL.248   
   20 CONTINUE                                                             INITAL.249   
C                                                                          INITAL.250   
C     Switch off output of moisture and heating fields if dry history.     INITAL.251   
C                                                                          INITAL.252   
      IF (LDRY) THEN                                                       INITAL.253   
         DO 30 IOUT=9,10                                                   INITAL.254   
         LSGGR(IOUT)=.FALSE.                                               SUNMOD.20    
   30    LSGPL(IOUT)=.FALSE.                                               SUNMOD.21    
         DO 40 IOUT=24,28                                                  INITAL.257   
         LXDGR(IOUT)=.FALSE.                                               SUNMOD.22    
   40    LXDPL(IOUT)=.FALSE.                                               SUNMOD.23    
      ENDIF                                                                INITAL.260   
C                                                                          INITAL.261   
C     Echo namelist to output channel.                                     INITAL.262   
C                                                                          INITAL.263   
      WRITE(6,'('' '')')                                                   INITAL.264   
      WRITE(6,INPB)                                                        INITAL.265   
      WRITE(6,INTM)                                                        TMAV5.26    
      WRITE(6,6100) NAME                                                   INITAL.266   
C                                                                          INITAL.267   
C     Check and modify the basic counters, derive others.                  INITAL.268   
C                                                                          INITAL.269   
      IF (KOUNTD.EQ.0) THEN                                                INITAL.270   
         WRITE(6,6903)                                                     INITAL.271   
         CALL ABORT                                                        INITAL.272   
      ENDIF                                                                INITAL.273   
      IF (KOUNTP.NE.KOUNTD*(KOUNTP/KOUNTD)) THEN                           INITAL.274   
         WRITE(6,6904)                                                     INITAL.275   
         CALL ABORT                                                        INITAL.276   
      ENDIF                                                                INITAL.277   
      IF (KOUNTF.NE.KOUNTD*(KOUNTF/KOUNTD)) THEN                           INITAL.278   
         WRITE(6,6905)                                                     INITAL.279   
         CALL ABORT                                                        INITAL.280   
      ENDIF                                                                INITAL.281   
      IF (KOUNTA.NE.KOUNTD*(KOUNTA/KOUNTD)) THEN                           INITAL.282   
         WRITE(6,6906)                                                     INITAL.283   
         CALL ABORT                                                        INITAL.284   
      ENDIF                                                                INITAL.285   
      IF (KOUNTE.NE.KOUNTD*(KOUNTE/KOUNTD)) THEN                           INITAL.286   
         WRITE(6,6907)                                                     INITAL.287   
         CALL ABORT                                                        INITAL.288   
      ENDIF                                                                INITAL.289   
      IF (KOUNTP.EQ.0) KOUNTP=-999999999                                   INITAL.290   
      IF (KOUNTF.EQ.0) KOUNTF=-999999999                                   INITAL.291   
      IF (KOUNTA.EQ.0) KOUNTA=-999999999                                   INITAL.292   
      IF (KOUNTE.EQ.0) KOUNTE=-999999999                                   INITAL.293   
      KHDAY =NINT(    .5*TSPD)                                             INITAL.294   
      KSTART=NINT(BEGDAY*TSPD)                                             INITAL.295   
      KEND  =NINT(ENDDAY*TSPD)                                             INITAL.296   
      KBEGP =NINT( BEGDP*TSPD)                                             INITAL.297   
      IF (LDRY) KBEGP=KEND+999                                             INITAL.298   
C                                                                          INITAL.299   
C     Check various namelist values.                                       INITAL.300   
C                                                                          INITAL.301   
      IF (NLAT.LT.0.OR.NLAT.GT.JG) THEN                                    INITAL.302   
         WRITE(6,6908)                                                     INITAL.303   
         CALL ABORT                                                        INITAL.304   
      ENDIF                                                                INITAL.305   
      IF (NLONG.LT.0.OR.NLONG.GT.MG) THEN                                  INITAL.306   
         WRITE(6,6909)                                                     INITAL.307   
         CALL ABORT                                                        INITAL.308   
      ENDIF                                                                INITAL.309   
      IF (NCOEFF.LT.0.OR.NCOEFF.GT.NN) THEN                                INITAL.310   
         WRITE(6,6910)                                                     INITAL.311   
         CALL ABORT                                                        INITAL.312   
      ENDIF                                                                INITAL.313   
      IF (LTHPL(1).OR.LTHPL(2)) THEN                                       INITAL.314   
         WRITE(6,6911)                                                     INITAL.315   
         LTHPL(1)=.FALSE.                                                  SUNMOD.24    
         LTHPL(2)=.FALSE.                                                  SUNMOD.25    
      ENDIF                                                                INITAL.318   
      NWJC=0                                                               INITAL.319   
      DO 50 MP=1,MFP,MOCT                                                  INITAL.320   
      DO 50 JP=MP,NFP,MH                                                   INITAL.321   
   50 NWJC=NWJC+1                                                          INITAL.322   
      IF (NWJC.NE.NWJ2) THEN                                               INITAL.323   
         WRITE(6,6912) NWJ2,NWJC                                           INITAL.324   
         CALL ABORT                                                        INITAL.325   
      ENDIF                                                                INITAL.326   
C                                                                          INITAL.327   
C     Non-dimensionalise variables input as dimensional.                   INITAL.328   
C                                                                          INITAL.329   
      DO 60 L=1,NL                                                         INITAL.330   
   60 IF (DRAG(L).GT.0.) DRAG(L)=WW*CG*P0/(GA*PI2*DRAG(L))                 INITAL.331   
C                                                                          INITAL.332   
      DO 70 L=1,NL                                                         INITAL.333   
   70 TMEAN(L)=TMEAN(L)/CT                                                 INITAL.334   
C                                                                          INITAL.335   
      DO 80 L=1,NTHSF                                                      INITAL.336   
   80 THSURF(L)=THSURD(L)/CT                                               INITAL.337   
C                                                                          INITAL.338   
      CPHASE=CPHASE/360.                                                   INITAL.339   
C                                                                          INITAL.340   
      DELT=PI2/TSPD                                                        INITAL.341   
      DELT2=DELT+DELT                                                      INITAL.342   
      DELTSQ=DELT*DELT                                                     INITAL.343   
C                                                                          INITAL.344   
C     Set factors for time averaging every KOUNTD steps.                   INITAL.345   
C     Preset time averages of zonal mean aarays.                           INITAL.346   
C                                                                          INITAL.347   
      KLEN=KEND-KSTART                                                     INITAL.348   
      NRTAV=KLEN/KOUNTD                                                    INITAL.349   
      FTAV=2.                                                              INITAL.350   
      IF (NRTAV.GT.0) FTAV=1./REAL(NRTAV)                                  ANSI2.293   
      LTAV=KEND.NE.KSTART                                                  INITAL.352   
      DO 90 I=1,IDDZ                                                       INITAL.353   
   90 DDZT(I)=0.                                                           INITAL.354   
C                                                                          TMAV5.58    
C     Initialise time averaging of 3D fields.                              TMAV5.59    
C                                                                          TMAV5.60    
      IF (LTIMAV) THEN                                                     TMAV5.61    
         IF (LPC6) CALL INITAV(NCTHG)                                      TMAV5.62    
         DO 600 I=1,NGP                                                    TMAV5.63    
         CALL INITAV(NCGP(I))                                              TMAV5.64    
  600    CONTINUE                                                          TMAV5.65    
      ENDIF                                                                TMAV5.66    
C                                                                          TMAV5.27    
C     Initialise transient flux calculations.                              TMAV5.28    
C     NFIL is the number of analyses in a low-pass averaging period.       TMAV5.29    
C                                                                          TMAV5.30    
      KFIL=3*NINT(TSPD)                                                    TMAV5.31    
      NFIL=KFIL/KOUNTD                                                     TMAV5.32    
      IF (LTFLUX) CALL INITF(BEGDAY,ENDDAY)                                TMAV5.33    
C                                                                          INITAL.355   
C     Initialise output of spectral coefficients.                          INITAL.356   
C                                                                          INITAL.357   
      I=1                                                                  INITAL.358   
      DO 110 MP=1,MFP,MOCT                                                 INITAL.359   
      IF (MP.GT.NCOEFF) GOTO 120                                           INITAL.360   
      DO 100 JP=MP,NCOEFF,MH                                               INITAL.361   
  100 I=I+1                                                                INITAL.362   
  110 CONTINUE                                                             INITAL.363   
  120 INSPC=I-1                                                            INITAL.364   
      CALL WRSPI(Z(1),1)                                                   INITAL.365   
C                                                                          INITAL.366   
C     Constants for KE spectra.                                            INITAL.367   
C                                                                          INITAL.368   
      NPTS4=0                                                              INITAL.370   
      RKEFAC=CG*P0/(2.*GA)                                                 INITAL.371   
      DO 130 I=1,NFP                                                       INITAL.372   
         RNWN(I)=REAL(I)                                                   ANSI2.294   
  130 CONTINUE                                                             ANSI2.295   
C                                                                          INITAL.374   
C     Spectral arrays for Legendre transforms.                             INITAL.375   
C                                                                          INITAL.376   
      SQ(1)=0.                                                             INITAL.377   
      RSQ(1)=0.                                                            INITAL.378   
      DO 140 NP=2,NFPP                                                     INITAL.379   
      SQ(NP)=NP*(NP-1)                                                     INITAL.380   
  140 RSQ(NP)=1./SQ(NP)                                                    INITAL.381   
C                                                                          INITAL.382   
C     Array to calculate x-derivatives of Fourier coefficients.            INITAL.383   
C                                                                          INITAL.384   
      DO 150 I=1,IGL                                                       INITAL.385   
  150 CMPA(I)=0.                                                           INITAL.386   
      NROW=0                                                               INITAL.387   
CDIR$ IVDEP                                                                INITAL.388   
      DO 160 MP=1,MFP,MOCT                                                 INITAL.389   
      NROW=NROW+1                                                          INITAL.390   
      CMPA(NROW)=CMPLX(0.,REAL(MP-1))                                      ANSI2.296   
      IF (NHEM.EQ.2) CMPA(NROW+IDL)=CMPA(NROW)                             INITAL.392   
  160 CONTINUE                                                             INITAL.393   
C                                                                          INITAL.394   
C     Auxiliary values required by FFT991.                                 INITAL.395   
C                                                                          INITAL.396   
      NTRWG=NLWG*NHEM                                                      INITAL.397   
      NTWG=(NTRWG-1)/NCRAY                                                 INITAL.398   
      NRSTWG=NTRWG-NCRAY*NTWG                                              INITAL.399   
      NTRNL=NL*NHEM                                                        INITAL.400   
      NTNL=(NTRNL-1)/NCRAY                                                 INITAL.401   
      NRSTNL=NTRNL-NCRAY*NTNL                                              INITAL.402   
      CALL FAX(IFAX,MG,3)                                                  INITAL.403   
      CALL FFTRIG(TRIG,MG,3)                                               INITAL.404   
C                                                                          INITAL.405   
C     Constants for output of grid point fields.                           INITAL.406   
C                                                                          INITAL.407   
      IF (NLAT.GT.0) INLAT=JG/NLAT                                         INITAL.408   
      IF (NLONG.GT.0) INLONG=MG/NLONG                                      INITAL.409   
C                                                                          INITAL.410   
C     Set up scratch files on SSD if required.                             INITAL.411   
C                                                                          INITAL.412   
      CALL INISSD(LCENTR)                                                  INITAL.413   
C                                                                          INITAL.414   
C     ----------------------------------------------------------------     INITAL.415   
C     Set up Gaussian latitudes and Legendre functions.                    INITAL.416   
C                                                                          INITAL.417   
      CALL INILAT                                                          INITAL.418   
      WRITE(6,6110) (ALAT(J),J=JG,1,-1)                                    INITAL.419   
C                                                                          INITAL.420   
C     ----------------------------------------------------------------     INITAL.421   
C     Set up sigma levels for vertical scheme.                             INITAL.422   
C                                                                          INITAL.423   
      CALL INILEV                                                          INITAL.424   
      WRITE(6,6120) SIGMAH                                                 INITAL.425   
      WRITE(6,6130) SIGMA                                                  INITAL.426   
C                                                                          INITAL.427   
C     Pressure levels for vertical interpolation and output.               INITAL.428   
C                                                                          INITAL.429   
      CALL INIPLV                                                          INITAL.430   
C                                                                          INITAL.431   
C     Derived arrays for vertical scheme.                                  INITAL.432   
C                                                                          INITAL.433   
      CALL INIVER                                                          INITAL.434   
C                                                                          INITAL.435   
C     Basic-state geopotential at full levels.                             INITAL.436   
C                                                                          INITAL.437   
      FAC=.001*CG/GA                                                       INITAL.438   
      IL=0                                                                 INITAL.439   
      DO 180 L=1,NL                                                        INITAL.440   
      HL=0.                                                                INITAL.441   
      DO 170 M=1,NL                                                        INITAL.442   
      IL=IL+1                                                              INITAL.443   
  170 HL=HL+G(IL)*TMEAN(M)                                                 INITAL.444   
  180 HEIGHT(L)=HL*FAC                                                     INITAL.445   
      WRITE(6,6140) (HEIGHT(L),L=1,NL)                                     INITAL.446   
C                                                                          INITAL.447   
C     Gravity wave speeds and time scheme matrix AQ.                       INITAL.448   
C                                                                          INITAL.449   
      IL=0                                                                 INITAL.450   
      INS=1                                                                INITAL.451   
      DO 210 L=1,NL                                                        INITAL.452   
      DO 200 M=1,NL                                                        INITAL.453   
      IN=INS                                                               INITAL.454   
      IL=IL+1                                                              INITAL.455   
      IM=M                                                                 INITAL.456   
      TAQ=TMEAN(L)*DSIGMA(M)                                               INITAL.457   
      DO 190 N=1,NL                                                        INITAL.458   
      TAQ=TAQ+G(IN)*TAU(IM)                                                INITAL.459   
      IN=IN+1                                                              INITAL.460   
  190 IM=IM+NL                                                             INITAL.461   
      AQ(IL)=TAQ                                                           INITAL.462   
  200 TBM1(IL)=TAQ                                                         INITAL.463   
  210 INS=INS+NL                                                           INITAL.464   
      CALL QREIG(TBM1,NL,NL,NL,CR,CI)                                      INITAL.465   
      DO 220 L=1,NL                                                        INITAL.466   
  220 CR(L)=CV*SQRT(CR(L))                                                 INITAL.467   
      WRITE(6,6150) (CR(L),L=1,NL)                                         INITAL.468   
C                                                                          INITAL.469   
C     ----------------------------------------------------------------     INITAL.470   
C     Initialise variables for parameterised processes.  Based on          INITAL.471   
C     parameterisations in simple GCM (SGCM), PDN=BGCM5,ID=UPLIB,ED=5.     INITAL.472   
C     Namelist INPHYS was read immediately after INPB.                     INITAL.473   
C     Derived values set up here require vertical levels from INILEV.      INITAL.474   
C                                                                          INITAL.475   
      WRITE(6,'('' '')')                                                   INITAL.476   
      WRITE(6,INPHYS)                                                      INITAL.477   
      IF (LDRY) THEN                                                       INITAL.478   
         WRITE(6,6200)                                                     INITAL.479   
      ELSE IF (LBL.OR.LVD.OR.LCR.OR.LLR.OR.LRD) THEN                       INITAL.480   
         WRITE(6,6210)                                                     INITAL.481   
      ELSE                                                                 INITAL.482   
         WRITE(6,6220)                                                     INITAL.483   
      ENDIF                                                                INITAL.484   
      IF (LBL) WRITE(6,6230) CD                                            INITAL.485   
      IF (LCR) WRITE(6,6240)                                               INITAL.486   
      IF (LLR) WRITE(6,6250)                                               INITAL.487   
      IF (LRD) WRITE(6,6260)                                               INITAL.488   
      IF (LVD) WRITE(6,6270) AKVV                                          INITAL.489   
      IF (LBL) READ(NCSURF) TSTAR,QSTAR                                    INITAL.490   
      ESCONB=CLATNT/RV                                                     INITAL.491   
      ESCONA=RD*EXP(ESCONB/273.15)*610.7/(RV*P0)                           INITAL.492   
      ESCONB=ESCONB/CT                                                     INITAL.493   
      BLCON=CD*GA*RADEA/(RD*CT*DSIGMA(NL))                                 INITAL.494   
      BLVAD=3./CV                                                          INITAL.495   
      CDIF=GA/(CV*WW)                                                      INITAL.496   
      CDIF=CDIF*CDIF                                                       INITAL.497   
      DO 230 L=1,NLM                                                       INITAL.498   
  230 FB(L)=CDIF*4.*SIGMAH(L)*SIGMAH(L)/(SIGMA(L+1)-SIGMA(L))              INITAL.499   
      AKVV=AKVV/(RADEA*CV)                                                 INITAL.500   
      IF (.NOT.LBL) THEN                                                   INITAL.501   
         DO 240 K=1,3                                                      INITAL.502   
         LPHGR(K)=.FALSE.                                                  SUNMOD.27    
  240    LPHPL(K)=.FALSE.                                                  SUNMOD.28    
      ENDIF                                                                INITAL.505   
      IF (.NOT.LCR) THEN                                                   INITAL.506   
         LPHGR(4)=.FALSE.                                                  SUNMOD.29    
         LPHPL(4)=.FALSE.                                                  SUNMOD.30    
      ENDIF                                                                INITAL.509   
      IF (.NOT.LLR) THEN                                                   INITAL.510   
         LPHGR(5)=.FALSE.                                                  SUNMOD.31    
         LPHPL(5)=.FALSE.                                                  SUNMOD.32    
      ENDIF                                                                INITAL.513   
      IF (.NOT.(LCR.AND.LLR)) THEN                                         INITAL.514   
         LPHGR(6)=.FALSE.                                                  SUNMOD.33    
         LPHPL(6)=.FALSE.                                                  SUNMOD.34    
      ENDIF                                                                INITAL.517   
C                                                                          INITAL.518   
C     ----------------------------------------------------------------     INITAL.519   
C     Initialise data transfer file (UTF).                                 INITAL.520   
C                                                                          INITAL.521   
      IF (KOUNTA.GT.0) CALL INIUTF(NAME,NPCA)                              INITAL.522   
C                                                                          INITAL.523   
C     Read and optionally output orography field.                          INITAL.528   
C                                                                          INITAL.529   
      CALL INIROG                                                          INITAL.530   
C                                                                          INITAL.531   
      RETURN                                                               INITAL.540   
      END                                                                  INITAL.541   
C     ****************************************************************     INITAL.542   
*DECK INISSD                                                               INISSD.1     
      SUBROUTINE INISSD(LCENTR)                                            INISSD.2     
C                                                                          INISSD.3     
C     In unicos cannot explicitly place files on SSD since used as         UCOS.39    
C     ld-cache.  Instead files in temporary directory can be on SSD,       UCOS.40    
C     though residence of individual files is determined by system.        UCOS.41    
C     If LSSD=.F. leave all scratch files in current directory.            UCOS.42    
C     If LSSD=.T. open all scratch files in temporary directory.           UCOS.43    
C     Current directory is checked to avoid unnecessary opens.             UCOS.44    
C     Sizes of scratch files checked against SSD device size limit         UCOS.45    
C     and informative message printed (no abort as in COS).                UCOS.46    
C                                                                          INISSD.7     
*CALL PARAM1                                                               INISSD.8     
*CALL PARAM2                                                               INISSD.9     
*CALL BATS                                                                 INISSD.10    
*CALL COMIOC                                                               INISSD.11    
*CALL COMROG                                                               INISSD.12    
*CALL OUTCON                                                               INISSD.13    
*CALL PHYS                                                                 INISSD.14    
*CALL TIMFLX                                                               BUGS4.13    
      CHARACTER LDEV*8,LCENTR*(*)                                          INISSD.15    
      SAVE LDEV                                                            INISSD.16    
C                                                                          INISSD.17    
      DATA NWGP,NWTHG,NWLEG,NWROGS,NWGEN,NWGDG,NWPLT2,NWPLT3/8*0/          INISSD.18    
      DATA NWTA,NWTF/2*0/                                                  BUGS4.14    
      DATA LDEV/'*SSD    '/                                                INISSD.19    
C                                                                          INISSD.20    
 6000 FORMAT(/' SCRATCH FILES IN TEMPORARY DIRECTORY AND NEED'             UCOS.47    
     :       ,I6,' SECTORS, ',I10,' WORDS')                                UCOS.48    
 6010 FORMAT(/' SCRATCH FILES IN CURRENT DIRECTORY AND NEED'               UCOS.49    
     :       ,I6,' SECTORS, ',I10,' WORDS')                                UCOS.50    
 6020 FORMAT( ' (IF ALL OPTIONS SWITCHED ON AT CURRENT RESOLUTION,'        INISSD.25    
     :       ,' SIZE WOULD BE ',I6,' SECTORS, ',I10,' WORDS)')             INISSD.26    
 6030 FORMAT(' CURRENT DIRECTORY IS TEMPORARY : NO ACTION NEEDED')         UCOS.51    
 6100 FORMAT(/' TIME-AVERAGING SCRATCH FILES USE',I10,' WORDS')            BUGS4.15    
 6110 FORMAT(/' (TIME-AVERAGING SCRATCH FILES WOULD USE',I10,' WORDS)')    BUGS4.16    
 6120 FORMAT(/' TRANSIENT FLUX SCRATCH FILES USE',I10,' WORDS')            BUGS4.17    
 6130 FORMAT(/' (TRANSIENT FLUX SCRATCH FILES WOULD USE',I10,' WORDS)')    BUGS4.18    
 6900 FORMAT(/' SCRATCH FILES WOULD EXCEED SSD DEVICE SIZE LIMIT OF'       UCOS.52    
     :       ,I6,' SECTORS')                                               UCOS.53    
 6910 FORMAT(/' ***INISSD : ERROR OPENING UNIT WITH PATH ',A/)             UCOS.54    
C                                                                          INISSD.30    
C     Calculate total space required for all scratch files.                INISSD.31    
C     NW, NS are values with current switch settings.  MW, MS are          INISSD.32    
C     maximum values at current resolution if all options switched on.     INISSD.33    
C     NW is number of Cray words, NS is number of 512-word sectors.        INISSD.34    
C     Latter is used for the *SSD parameter on the COS job statement.      UCOS.55    
C                                                                          INISSD.36    
C     Channels NCGP(i) for model level / isobaric grid-point data.         INISSD.37    
      MWGP=((NSG-2+2)*IGD+4*IGC)*JG                                        INISSD.38    
      IF (LPC2.OR.LPC3.OR.LPC5.OR.LPC6) NWGP=MWGP                          INISSD.39    
C                                                                          INISSD.40    
C     Channel NCTHG for isentropic data.                                   INISSD.41    
      MWTHG=NTH*IDTHSF*JG                                                  BUGS4.19    
      IF (LPC6) NWTHG=MWTHG                                                INISSD.43    
C                                                                          INISSD.44    
C     Channels NCLEG for Legendre Functions and NCROGS for orography.      INISSD.45    
      MWLEG=4*MJP*JG                                                       INISSD.46    
      MWROGS=IGC*JG                                                        INISSD.47    
      IF (JGL.EQ.1) THEN                                                   INISSD.48    
         NWLEG=MWLEG                                                       INISSD.49    
         IF (LROG) NWROGS=MWROGS                                           INISSD.50    
      ENDIF                                                                INISSD.51    
C                                                                          INISSD.52    
C     Channel NCGEN for global energetics time series.                     INISSD.53    
      NTIMES=NRTAV+1                                                       INISSD.54    
      IF (LTAV) NTIMES=NTIMES+1                                            INISSD.55    
      MWGEN=(2+NTERM5+3)*NTIMES                                            INISSD.56    
      IF (LPC5) NWGEN=MWGEN                                                INISSD.57    
C                                                                          INISSD.58    
C     Channel NCGDG for global surface diagnostics time series.            INISSD.59    
      NTIMES=(KEND-KBEGP)/KOUNTD                                           INISSD.60    
      MWGDG=(2+2*NPH)*NTIMES+2                                             INISSD.61    
      IF (LPC9.AND.KEND.GT.KBEGP) NWGDG=MWGDG                              INISSD.62    
C                                                                          INISSD.63    
C     Channels NCPLOT(2-3) for KE spectra scratch files.                   INISSD.64    
C     Following calc. is not exact but is max used: see LOUTE logic.       INISSD.65    
      IF (KOUNTE.GT.0) THEN                                                INISSD.66    
         NTIMES=1+(KEND-KSTART)/KOUNTE                                     INISSD.67    
      ELSE                                                                 INISSD.68    
         NTIMES=NPMAX4                                                     INISSD.69    
      ENDIF                                                                INISSD.70    
      NTRUNC=MIN0(NTIMES,NPMAX4)                                           INISSD.71    
C     Channel NCPLOT(2).                                                   INISSD.72    
      MWPLT2=NTIMES*(16+2*(NWW-1))+(16+4+NTRUNC)                           INISSD.73    
C     Channel NCPLOT(3).                                                   INISSD.74    
      NPTS=MIN0(NWW-1,21/MOCT)                                             INISSD.75    
      MWPLT3=NTRUNC*(1+NPTS)                                               INISSD.76    
      IF (KOUNTE.GT.0.AND.LSPPLT) THEN                                     INISSD.77    
         NWPLT2=MWPLT2                                                     INISSD.78    
         NWPLT3=MWPLT3                                                     INISSD.79    
      ENDIF                                                                INISSD.80    
C                                                                          BUGS4.20    
C     Time averaging scratch files.                                        BUGS4.21    
      MWTA=MWGP+MWTHG                                                      BUGS4.22    
      IF (LTIMAV) NWTA=MWGP                                                BUGS4.23    
      IF (LTIMAV.AND.LPC6) NWTA=NWTA+MWTHG                                 BUGS4.24    
C                                                                          BUGS4.25    
C     Transient flux scratch files.                                        BUGS4.26    
      MWTF=NTF*2*6*IGD*JG                                                  BUGS4.27    
      IF (LTFLUX) NWTF=MWTF                                                BUGS4.28    
C                                                                          INISSD.81    
      NW=NWGP+NWTHG+NWLEG+NWROGS+NWGEN+NWGDG+NWPLT2+NWPLT3                 INISSD.82    
     &   +NWTA+NWTF                                                        BUGS4.29    
      NS=(NW+511)/512                                                      INISSD.83    
      MW=MWGP+MWTHG+MWLEG+MWROGS+MWGEN+MWGDG+MWPLT2+MWPLT3                 INISSD.84    
     &   +MWTA+MWTF                                                        BUGS4.30    
      MS=(MW+511)/512                                                      INISSD.85    
C                                                                          BUGS4.31    
      IF (LTIMAV) THEN                                                     BUGS4.32    
         WRITE(6,6100) MWTA                                                BUGS4.33    
      ELSE                                                                 BUGS4.34    
         WRITE(6,6110) MWTA                                                BUGS4.35    
      ENDIF                                                                BUGS4.36    
      IF (LTFLUX) THEN                                                     BUGS4.37    
         WRITE(6,6120) MWTF                                                BUGS4.38    
      ELSE                                                                 BUGS4.39    
         WRITE(6,6130) MWTF                                                BUGS4.40    
      ENDIF                                                                BUGS4.41    
C                                                                          INISSD.86    
C     Check whether explicit opens are needed : only if SSD requested,     UCOS.56    
C     if at RAL and if working directory is not temporary.                 UCOS.57    
C                                                                          INISSD.88    
      IF (LSSD.AND.(LCENTR.EQ.'RAL')) THEN                                 INISSD.89    
         WRITE(6,6000) NS,NW                                               UCOS.58    
         WRITE(6,6020) MS,MW                                               INISSD.91    
         IF (CPTHWD.EQ.CPTHTD) THEN                                        UCOS.59    
            WRITE(6,6030)                                                  UCOS.60    
            RETURN                                                         UCOS.61    
         ENDIF                                                             UCOS.62    
      ELSE                                                                 INISSD.92    
         WRITE(6,6010) NS,NW                                               INISSD.93    
         WRITE(6,6020) MS,MW                                               INISSD.94    
         RETURN                                                            INISSD.95    
      ENDIF                                                                INISSD.96    
C                                                                          INISSD.97    
C     Check total size of scratch files against SSD device limit of        UCOS.63    
C     NSMAX * 512word sectors.  Message is for information only in         UCOS.64    
C     unicos.  If largest files are wanted on SSD, try omitting            UCOS.65    
C     channels not used (output types not switched on), or try omitting    INISSD.101   
C     in order: NCPLOT(2-3), NCGEN, NCGDG, NCROGG, NCLEG, NCTHG,           INISSD.102   
C     then finally some of NCGP(1-NGP).                                    INISSD.103   
C                                                                          INISSD.104   
      NSMAX=128000000/512                                                  UCOS.66    
      IF (NS.GT.NSMAX) WRITE(6,6900) NSMAX                                 UCOS.67    
C                                                                          INISSD.110   
C     Assign individual channels.                                          INISSD.111   
C                                                                          INISSD.112   
      IF (LPC2.OR.LPC3.OR.LPC5.OR.LPC6) THEN                               INISSD.113   
         DO 10 I=1,NGP                                                     INISSD.114   
         OPEN(NCGP(I),FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                    UCOS.68    
     :       ,FORM='UNFORMATTED',ERR=900)                                  UCOS.69    
   10    CONTINUE                                                          INISSD.117   
      ENDIF                                                                INISSD.118   
C                                                                          INISSD.119   
      IF (LPC6) THEN                                                       INISSD.120   
         OPEN(NCTHG,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                      UCOS.70    
     :       ,FORM='UNFORMATTED',ERR=900)                                  UCOS.71    
      ENDIF                                                                INISSD.123   
C                                                                          INISSD.124   
      IF (JGL.EQ.1) THEN                                                   INISSD.125   
         OPEN(NCLEG,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                      UCOS.72    
     :       ,FORM='UNFORMATTED',ERR=900)                                  UCOS.73    
         IF (LROG) THEN                                                    INISSD.128   
            OPEN(NCROGG,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                  UCOS.74    
     :          ,FORM='UNFORMATTED',ERR=900)                               UCOS.75    
         ENDIF                                                             INISSD.131   
      ENDIF                                                                INISSD.132   
C                                                                          INISSD.133   
      IF (LPC5) THEN                                                       INISSD.134   
         OPEN(NCGEN,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                      UCOS.76    
     :       ,FORM='UNFORMATTED',ERR=900)                                  UCOS.77    
      ENDIF                                                                INISSD.137   
C                                                                          INISSD.138   
      IF (LPC9.AND.KEND.GT.KBEGP) THEN                                     INISSD.139   
         OPEN(NCGDG,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                      UCOS.78    
     :       ,FORM='UNFORMATTED',ERR=900)                                  UCOS.79    
      ENDIF                                                                INISSD.142   
C                                                                          BUGS4.42    
C     Time averaging scratch files.                                        BUGS4.43    
C                                                                          BUGS4.44    
      IF (LTIMAV) THEN                                                     BUGS4.45    
         DO 20 I=1,NGP                                                     BUGS4.46    
         OPEN(NCGP(I)+NCTADD,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN             BUGS4.47    
     &       ,FORM='UNFORMATTED',ERR=900)                                  BUGS4.48    
   20    CONTINUE                                                          BUGS4.49    
         IF (LPC6) THEN                                                    BUGS4.50    
            OPEN(NCTHG+NCTADD,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN            BUGS4.51    
     &          ,FORM='UNFORMATTED',ERR=900)                               BUGS4.52    
         ENDIF                                                             BUGS4.53    
      ENDIF                                                                BUGS4.54    
C                                                                          BUGS4.55    
C     Transient flux scratch file pairs.                                   BUGS4.56    
C                                                                          BUGS4.57    
      IF (LTFLUX) THEN                                                     BUGS4.58    
         DO 30 I=1,NTF                                                     BUGS4.59    
         OPEN(I+NCTFI,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                    BUGS4.60    
     &       ,FORM='UNFORMATTED',ERR=900)                                  BUGS4.61    
         OPEN(I+NCTFO,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN                    BUGS4.62    
     &       ,FORM='UNFORMATTED',ERR=900)                                  BUGS4.63    
   30    CONTINUE                                                          BUGS4.64    
      ENDIF                                                                BUGS4.65    
C                                                                          BUGS4.66    
C     Open retained plot-files implicitly in the current directory.        BUGS4.67    
C                                                                          BUGS4.68    
      IF ((LPC5.AND.LENCOP).OR.(LPC9.AND.LPHCOP)) THEN                     BUGS4.69    
         OPEN(NCPLOT(1),FORM='FORMATTED')                                  BUGS4.70    
      ENDIF                                                                BUGS4.71    
C                                                                          INISSD.143   
      IF (KOUNTE.GT.0.AND.LSPPLT) THEN                                     INISSD.144   
         OPEN(NCPLOT(2),FORM='FORMATTED')                                  BUGS4.72    
         OPEN(NCPLOT(3),FORM='FORMATTED')                                  BUGS4.73    
      ENDIF                                                                INISSD.149   
C                                                                          INISSD.150   
      RETURN                                                               INISSD.151   
C                                                                          UCOS.84    
C     Error trapping : print message and return if OPEN fails.             UCOS.85    
C                                                                          UCOS.86    
  900 WRITE(6,6910) CPTHTD(1:NLENTD)//'/'//LCHAN                           UCOS.87    
      RETURN                                                               UCOS.88    
C                                                                          UCOS.89    
      END                                                                  INISSD.152   
C     ****************************************************************     INISSD.153   
*DECK INILAT                                                               INILAT.1     
      SUBROUTINE INILAT                                                    INILAT.2     
C                                                                          INILAT.3     
C     Set up Gaussian latitudes and Legendre functions.                    INILAT.4     
C     Subroutine GWTLT calculates Gaussian weights and latitudes.          INILAT.5     
C     Subroutine LGNDRE calculates Associated Legendre Functions (ALP)     INILAT.6     
C     and their derivatives (DALP).                                        INILAT.7     
C                                                                          INILAT.8     
*CALL PARAM1                                                               INILAT.9     
*CALL PARAM2                                                               INILAT.10    
*CALL BATS                                                                 INILAT.11    
*CALL BLANK                                                                INILAT.12    
*CALL COMIOC                                                               INILAT.13    
*CALL LEGAU                                                                INILAT.14    
      IF (JGL.EQ.1)  JINC=0.                                               INILAT.15    
      IF (JGL.EQ.JG) JINC=1                                                INILAT.16    
C                                                                          INILAT.17    
      JL=1                                                                 INILAT.18    
      DO 20 J=1,JG                                                         INILAT.19    
      JH=J                                                                 INILAT.20    
      CALL GWTLT(SIJ,WEIGHT,J,JG)                                          INILAT.21    
      SI(J)=SIJ                                                            INILAT.22    
      SISQ(J)=SI(J)*SI(J)                                                  INILAT.23    
      CSSQ(J)=1.-SISQ(J)                                                   INILAT.24    
      CS(J)=SQRT(CSSQ(J))                                                  INILAT.25    
      GWT(J)=WEIGHT/REAL(NHEM)                                             ANSI2.297   
      CALL LGNDRE                                                          INILAT.27    
      IP=0                                                                 INILAT.28    
      DO 10 MP=1,MFP,MOCT                                                  INILAT.29    
      N=MP-1                                                               INILAT.30    
      NMAX=MP+((NFP-MP)/2)*2+1                                             INILAT.31    
      DO 10 JP=MP,NMAX                                                     INILAT.32    
      IP=IP+1                                                              INILAT.33    
      N=N+1                                                                INILAT.34    
      RLP(IP,JL)=-RSQ(N)*ALP(IP,JL)                                        INILAT.35    
      RDLP(IP,JL)=-RSQ(N)*DALP(IP,JL)                                      INILAT.36    
   10 CONTINUE                                                             INILAT.37    
      IF (JGL.EQ.1) WRITE(NCLEG) ALP,DALP,RLP,RDLP                         INILAT.38    
   20 JL=JL+JINC                                                           INILAT.39    
C                                                                          INILAT.40    
      DO 30 J=1,JG                                                         INILAT.41    
      SECSQ(J)=1./CSSQ(J)                                                  INILAT.42    
      ALAT(J)=ATAN(SI(J)/CS(J))*180./PI                                    INILAT.43    
      AW(J)=GWT(J)*REAL(NHEM)*2.*SECSQ(J)                                  ANSI2.298   
   30 CONTINUE                                                             INILAT.45    
      IF (NHEM.EQ.2) THEN                                                  INILAT.46    
CDIR$ IVDEP                                                                INILAT.47    
         DO 40 J=1,JG                                                      INILAT.48    
         SI(JGGP-J)=-SI(J)                                                 INILAT.49    
         CS(JGGP-J)=CS(J)                                                  INILAT.50    
         SISQ(JGGP-J)=SISQ(J)                                              INILAT.51    
         CSSQ(JGGP-J)=CSSQ(J)                                              INILAT.52    
         SECSQ(JGGP-J)=SECSQ(J)                                            INILAT.53    
         ALAT(JGGP-J)=-ALAT(J)                                             INILAT.54    
         GWT(JGGP-J)=GWT(J)                                                INILAT.55    
         AW(JGGP-J)=AW(J)                                                  INILAT.56    
   40    CONTINUE                                                          INILAT.57    
      ENDIF                                                                INILAT.58    
C                                                                          INILAT.59    
C     Set up factors for extrapolation at poles.                           INILAT.60    
C     Used in routine FLUX for y-derivatives of dynamical fields.          INILAT.61    
C                                                                          INILAT.62    
      EXN1=(SI(3)-SI(1))/(SI(3)-SI(2))                                     INILAT.63    
      EXN2=(SI(2)-SI(1))/(SI(3)-SI(2))                                     INILAT.64    
      EXS1=(SI(JGGM2)-SI(JGG))/(SI(JGGM2)-SI(JGGM))                        INILAT.65    
      EXS2=(SI(JGGM)-SI(JGG))/(SI(JGGM2)-SI(JGGM))                         INILAT.66    
C                                                                          INILAT.67    
C     Set up factors for extrapolation/interpolation to equator.           INILAT.68    
C     Used for plotting and dumping lat-long fields.                       INILAT.69    
C                                                                          INILAT.70    
      IF (NHEM.EQ.1) THEN                                                  INILAT.71    
         EXE1=ALAT(JG)*ALAT(JG)                                            INILAT.72    
         EXE2=ALAT(JG-1)*ALAT(JG-1)                                        INILAT.73    
      ELSE                                                                 INILAT.74    
         EXE1=ALAT(JG)                                                     INILAT.75    
         EXE2=ALAT(JG-1)                                                   INILAT.76    
      ENDIF                                                                INILAT.77    
      EXE3=1./(EXE2-EXE1)                                                  INILAT.78    
C                                                                          INILAT.79    
      RETURN                                                               INILAT.80    
      END                                                                  INILAT.81    
C     ****************************************************************     INILAT.82    
*DECK LGNDRE                                                               LGNDRE.1     
      SUBROUTINE LGNDRE                                                    LGNDRE.2     
C                                                                          LGNDRE.3     
C     Calculate Associated Legendre Functions at current latitude          LGNDRE.4     
C     in array ALP and their meridional derivatives in array DALP.         LGNDRE.5     
C          ALP = Pnm,     DALP = (1-mu**2)dPnm/dmu.                        LGNDRE.6     
C     Spectral truncation is jagged triangular at total wavenumber         LGNDRE.7     
C     NN (defined in parameter statement), with equal numbers of           LGNDRE.8     
C     even and odd functions for each zonal wavenumber.                    LGNDRE.9     
C     Includes zonal wavenumbers 0, MOCT, 2*MOCT,... to maximum NN-1.      LGNDRE.10    
C     Uses latitude counter JH in common LEGAU as the subscript            LGNDRE.11    
C     of the SI array for mu=sin(lat) and CS for cos(lat).                 LGNDRE.12    
C                                                                          LGNDRE.13    
*CALL PARAM1                                                               LGNDRE.14    
*CALL PARAM2                                                               LGNDRE.15    
*CALL BLANK                                                                LGNDRE.16    
*CALL LEGAU                                                                LGNDRE.17    
      LM=2                                                                 LGNDRE.18    
      ALP(1,JL)=SQRT(.5)                                                   LGNDRE.19    
      F1M=SQRT(1.5)                                                        LGNDRE.20    
      ALP(2,JL)=F1M*SI(JH)                                                 LGNDRE.21    
      DALP(1,JL)=0.                                                        LGNDRE.22    
      DO 40 M1=1,MFP                                                       LGNDRE.23    
      M=M1-1                                                               LGNDRE.24    
      AM=M                                                                 LGNDRE.25    
      A2M=M+M                                                              LGNDRE.26    
      E2=SQRT(A2M+3.)                                                      LGNDRE.27    
      IF (M.EQ.0) GOTO 10                                                  LGNDRE.28    
      F2M=-F1M*CS(JH)/SQRT(A2M)                                            LGNDRE.29    
      F1M=F2M*E2                                                           LGNDRE.30    
      IF (M.NE.MMO) GOTO 40                                                LGNDRE.31    
      LM=LM+1                                                              LGNDRE.32    
      ALP(LM,JL)=F2M                                                       LGNDRE.33    
      LM=LM+1                                                              LGNDRE.34    
      ALP(LM,JL)=F1M*SI(JH)                                                LGNDRE.35    
      DALP(LM-1,JL)=-AM*ALP(LM,JL)/E2                                      LGNDRE.36    
   10 M2=M+2                                                               LGNDRE.37    
      MMO=M+MOCT                                                           LGNDRE.38    
      JFM=((NFP-M1)/2)*2+M2-1                                              LGNDRE.39    
      IF (JFM.LT.M2) GOTO 30                                               LGNDRE.40    
      K=LM-M2+1                                                            LGNDRE.41    
      AMSQ=AM*AM                                                           LGNDRE.42    
      DO 20 N=M2,JFM                                                       LGNDRE.43    
      AN=N                                                                 LGNDRE.44    
      AN2=N*N                                                              LGNDRE.45    
      ANM2=(N-1)*(N-1)                                                     LGNDRE.46    
      E1=SQRT((ANM2-AMSQ)/(4.*ANM2-1.))                                    LGNDRE.47    
      E2=SQRT((4.*AN2-1.)/(AN2-AMSQ))                                      LGNDRE.48    
      ALP(K+N,JL)=E2*(SI(JH)*ALP(K+N-1,JL)-E1*ALP(K+N-2,JL))               LGNDRE.49    
      DALP(K+N-1,JL)= (1.-AN)*ALP(K+N,JL)/E2+AN*E1*ALP(K+N-2,JL)           LGNDRE.50    
   20 CONTINUE                                                             LGNDRE.51    
      LM=LM+JFM-M2+1                                                       LGNDRE.52    
   30 CONTINUE                                                             LGNDRE.53    
      DALP(LM,JL)=-AN*SI(JH)*ALP(LM,JL)+(AN+AN+1.)*ALP(LM-1,JL)/E2         LGNDRE.54    
   40 CONTINUE                                                             LGNDRE.55    
C                                                                          LGNDRE.56    
      RETURN                                                               LGNDRE.57    
      END                                                                  LGNDRE.58    
C     ****************************************************************     LGNDRE.59    
*DECK INILEV                                                               INILEV.1     
      SUBROUTINE INILEV                                                    INILEV.2     
C                                                                          INILEV.3     
C     Set up sigma levels for vertical scheme.                             INILEV.4     
C     Equispaced for NL <= 5.                                              INILEV.5     
C                                                                          INILEV.6     
*CALL PARAM1                                                               INILEV.7     
*CALL PARAM2                                                               INILEV.8     
*CALL BLANK                                                                INILEV.9     
      STP=1./REAL(NL)                                                      ANSI2.299   
      IF (NL.LE.5) THEN                                                    INILEV.11    
         DO 10 L=1,NLM                                                     INILEV.12    
   10    SIGMAH(L)=L*STP                                                   INILEV.13    
      ELSE                                                                 INILEV.14    
         T1=(.9375/.94-1.25)/(.9375*(SQRT(.9375)-1.))                      INILEV.15    
         T2=4.+T1                                                          INILEV.16    
         P=0.                                                              INILEV.17    
         DO 20 L=1,NLM                                                     INILEV.18    
         P=P+STP                                                           INILEV.19    
         VV=P/(5.-T2*P+T1*(P**1.5))                                        INILEV.20    
         VV=VV*(2.-P)*(1.+.25*SIN(PI2*(P**.6)))                            INILEV.21    
         SIGMAH(L)=VV                                                      INILEV.22    
   20    CONTINUE                                                          INILEV.23    
      ENDIF                                                                INILEV.24    
C                                                                          INILEV.25    
      S1=0.                                                                INILEV.26    
      DO 30 L=1,NLM                                                        INILEV.27    
      S2=SIGMAH(L)                                                         INILEV.28    
      DSIGMA(L)=S2-S1                                                      INILEV.29    
      SIGMA(L)=.5*(S2+S1)                                                  INILEV.30    
   30 S1=S2                                                                INILEV.31    
      DSIGMA(NL)=1.-SIGMAH(NLM)                                            INILEV.32    
      SIGMA(NL)=.5*(1.+SIGMAH(NLM))                                        INILEV.33    
C                                                                          INILEV.34    
      DO 40 L=1,NL                                                         INILEV.35    
      SIGMAK(L)=SIGMA(L)**(-AKAP)                                          INILEV.36    
      SIGM1K(L)=SIGMAK(L)/SIGMA(L)                                         INILEV.37    
      RDSIG(L)=.5/DSIGMA(L)                                                INILEV.38    
   40 CONTINUE                                                             INILEV.39    
C                                                                          INILEV.40    
      RETURN                                                               INILEV.41    
      END                                                                  INILEV.42    
C     ****************************************************************     INILEV.43    
*DECK INIPLV                                                               INIPLV.1     
      SUBROUTINE INIPLV                                                    INIPLV.2     
C                                                                          INIPLV.3     
C     Set up pressure levels for vertical interpolation.                   INIPLV.4     
C     Default in INPB gives NL levels with p(l) = sigma(l) * p0.           INIPLV.5     
C     PPR array is non-dimensional.  PLOUT is in mb for titles.            INIPLV.6     
C     Check and modify switches for interpolation and output streams.      INIPLV.7     
C                                                                          INIPLV.8     
*CALL PARAM1                                                               INIPLV.9     
*CALL PARAM2                                                               INIPLV.10    
*CALL BLANK                                                                INIPLV.11    
*CALL COMPRL                                                               INIPLV.12    
*CALL OUTCON                                                               INIPLV.13    
 6000 FORMAT(/' OUTPUT PRESSURE LEVELS (MB)'/(1X,15F7.1))                  INIPLV.14    
 6010 FORMAT(/' FIELDS INTERPOLATED TO PRESSURE FOR LAT-LONG OUTPUT')      INIPLV.15    
 6020 FORMAT(/' FIELDS INTERPOLATED TO PRESSURE FOR ZONAL/GLOBAL DIAGS')   INIPLV.16    
 6900 FORMAT(/' ***ABORT IN INIPLV: MORE THAN NL PRESSURE LEVELS'          INIPLV.17    
     :       ,' REQUESTED - NOT ALLOWED')                                  INIPLV.18    
 6910 FORMAT(/' ***WARNING: ZONAL AVERAGES CANNOT BE CALCULATED USING'     INIPLV.19    
     :       ,' ARBITRARY PRESSURE LEVELS - LPC3 SWITCHED OFF')            INIPLV.20    
 6920 FORMAT(/' ***WARNING: GLOBAL DIAGS CANNOT BE CALCULATED USING'       INIPLV.21    
     :       ,' ARBITRARY PRESSURE LEVELS - LPC5 SWITCHED OFF')            INIPLV.22    
 6930 FORMAT(/' ***ABORT IN INIPLV: PRESSURE LEVELS IN PLOUT ARRAY IN'     INIPLV.23    
     :       ,' NAMELIST INPB MUST BE IN INCREASING ORDER')                INIPLV.24    
 6940 FORMAT(/' ***ABORT IN INIPLV: OUTPUT PRESSURE LEVEL',F10.1           INIPLV.25    
     :       ,' IS OUTSIDE VALID RANGE')                                   INIPLV.26    
 6950 FORMAT(/' ***WARNING : NO VERTICAL INTERPOLATION OF ZONAL MEAN'      INIPLV.27    
     :       ,' FIELDS TO PRESSURE LEVELS :'                               INIPLV.28    
     :       /' GLOBAL DIAGNOSTICS IN GDIAG INCORRECT, SO SWITCHED OFF')   INIPLV.29    
 6960 FORMAT(/' ***WARNING : MODEL LEVEL FIELDS INTERPOLATED TO'           INIPLV.30    
     :       ,' PRESSURE LEVELS IN GRMULT (LINTP2=.TRUE.) :'               SUNMOD.35    
     :       /' ZONAL MEAN FIELDS MUST BE ISOBARIC : LINTP3 RESET =.TRUE   SUNMOD.36    
     :.')                                                                  SUNMOD.37    
C                                                                          INIPLV.33    
      IF (.NOT.(LINTP2.OR.LINTP3)) GOTO 100                                INIPLV.34    
C                                                                          INIPLV.35    
      NLTEMP=NLPR                                                          INIPLV.36    
      IF (NLTEMP.GT.NL) THEN                                               INIPLV.37    
         WRITE(6,6900)                                                     INIPLV.38    
         CALL ABORT                                                        INIPLV.39    
      ELSE IF (NLTEMP.GT.0) THEN                                           INIPLV.40    
         LINTP3=.FALSE.                                                    SUNMOD.38    
         IF (LPC3) THEN                                                    INIPLV.42    
            LPC3=.FALSE.                                                   SUNMOD.39    
            WRITE(6,6910)                                                  INIPLV.44    
         ENDIF                                                             INIPLV.45    
         IF (LPC5) THEN                                                    INIPLV.46    
            LPC5=.FALSE.                                                   SUNMOD.40    
            WRITE(6,6920)                                                  INIPLV.48    
         ENDIF                                                             INIPLV.49    
         WRITE(6,6000) (PLOUT(L),L=1,NLTEMP)                               INIPLV.50    
         DO 10 L=2,NLTEMP                                                  INIPLV.51    
         IF (PLOUT(L).LT.PLOUT(L-1)) THEN                                  INIPLV.52    
            WRITE(6,6930)                                                  INIPLV.53    
            CALL ABORT                                                     INIPLV.54    
         ENDIF                                                             INIPLV.55    
   10    CONTINUE                                                          INIPLV.56    
         DO 20 L=1,NLTEMP                                                  INIPLV.57    
         PPR(L)=PLOUT(L)*100./P0                                           INIPLV.58    
         IF (PPR(L).LE.0..OR.PPR(L).GT.1.2) THEN                           INIPLV.59    
            WRITE(6,6940) PLOUT(L)                                         INIPLV.60    
            CALL ABORT                                                     INIPLV.61    
         ENDIF                                                             INIPLV.62    
   20    CONTINUE                                                          INIPLV.63    
      ELSE IF (NLTEMP.LE.0) THEN                                           INIPLV.64    
         NLPR=NL                                                           INIPLV.65    
         DO 30 L=1,NLPR                                                    INIPLV.66    
         PPR(L)=SIGMA(L)                                                   INIPLV.67    
   30    PLOUT(L)=PPR(L)*P0/100.                                           INIPLV.68    
         WRITE(6,6000) (PLOUT(L),L=1,NL)                                   INIPLV.69    
      ENDIF                                                                INIPLV.70    
C                                                                          INIPLV.71    
  100 CONTINUE                                                             INIPLV.72    
      IF ((.NOT.(LINTP2.OR.LINTP3)).AND.LPC5) THEN                         INIPLV.73    
         LPC5=.FALSE.                                                      SUNMOD.41    
         WRITE(6,6950)                                                     INIPLV.75    
      ENDIF                                                                INIPLV.76    
      IF (LINTP2.AND.(.NOT.LINTP3).AND.(LPC3.OR.LPC5)) THEN                INIPLV.77    
         LINTP3=.TRUE.                                                     SUNMOD.42    
         WRITE(6,6960)                                                     INIPLV.79    
      ENDIF                                                                INIPLV.80    
C                                                                          INIPLV.81    
      IF (LINTP2.AND.LPC2) WRITE(6,6010)                                   INIPLV.82    
      IF (LINTP3.AND.(LPC3.OR.LPC5)) WRITE(6,6020)                         INIPLV.83    
C                                                                          INIPLV.84    
      RETURN                                                               INIPLV.85    
      END                                                                  INIPLV.86    
C     ****************************************************************     INIPLV.87    
*DECK INIVER                                                               INIVER.1     
      SUBROUTINE INIVER                                                    INIVER.2     
C                                                                          INIVER.3     
C     Set up derived arrays for vertical scheme.                           INIVER.4     
C                                                                          INIVER.5     
*CALL PARAM1                                                               INIVER.6     
*CALL PARAM2                                                               INIVER.7     
*CALL BATS                                                                 INIVER.8     
*CALL BLANK                                                                INIVER.9     
C                                                                          INIVER.10    
C     G and ALPHA matrices, TKP and T01S2 vectors.                         INIVER.11    
C     This value of S1, used in setting ALPHA(1), is irrelevant            INIVER.12    
C     in the angular momentum conserving ECMWF scheme.                     INIVER.13    
C                                                                          INIVER.14    
      S1=LOG(SIGMA(1)*SIGMA(1)/SIGMAH(1))                                  SUNMOD.88    
      T0M=TMEAN(1)                                                         INIVER.16    
      IG=1                                                                 INIVER.17    
      DO 10 L=1,NLM                                                        INIVER.18    
      LP=L+1                                                               INIVER.19    
      S2=LOG(SIGMAH(L))                                                    SUNMOD.89    
      T0P=TMEAN(LP)                                                        INIVER.21    
      IG=IG+NL                                                             INIVER.22    
      G(IG)=0.                                                             INIVER.23    
      T01S2(L)=T0P-T0M                                                     INIVER.24    
      ALPHA(L)=S2-S1                                                       INIVER.25    
      TKP(L)=AKAP*T0M                                                      INIVER.26    
      T0M=T0P                                                              INIVER.27    
   10 S1=S2                                                                INIVER.28    
      ALPHA(NL)=-S1                                                        INIVER.29    
      TKP(NL)=AKAP*T0M                                                     INIVER.30    
      G(1)=1.0                                                             INIVER.31    
      DO 40 J=2,NL                                                         INIVER.32    
      ALJ=ALPHA(J)                                                         INIVER.33    
      IG=J                                                                 INIVER.34    
      LIM=J-1                                                              INIVER.35    
      DO 20 I=1,LIM                                                        INIVER.36    
      G(IG)=ALJ                                                            INIVER.37    
   20 IG=IG+NL                                                             INIVER.38    
      G(IG)=1.0-ALJ*SIGMAH(LIM)/DSIGMA(J)                                  INIVER.39    
      IF (J.EQ.NL) GOTO 40                                                 INIVER.40    
      LIM=LIM+2                                                            INIVER.41    
      DO 30 I=LIM,NL                                                       INIVER.42    
      IG=IG+NL                                                             INIVER.43    
   30 G(IG)=0.                                                             INIVER.44    
   40 CONTINUE                                                             INIVER.45    
C                                                                          INIVER.46    
C     C matrix.                                                            INIVER.47    
C                                                                          INIVER.48    
      IC=-1                                                                INIVER.49    
      DO 50 I=1,NL                                                         INIVER.50    
      IC=IC+1                                                              INIVER.51    
      JC=IC*NLP                                                            INIVER.52    
      JCC=JC-NLM                                                           INIVER.53    
      DO 50 J=I,NL                                                         INIVER.54    
      JC=JC+1                                                              INIVER.55    
      JCC=JCC+NL                                                           INIVER.56    
   50 C(JCC)=G(JC)*DSIGMA(I)/DSIGMA(J)                                     INIVER.57    
C                                                                          INIVER.58    
C     TAU vector.                                                          INIVER.59    
C                                                                          INIVER.60    
      TT01S2=T01S2(1)                                                      INIVER.61    
      TAU(1)=0.5*TT01S2*(SIGMAH(1)-1.0)+TKP(1)*C(1)                        INIVER.62    
      DO 60 L=2,NL                                                         INIVER.63    
   60 TAU(L)=0.5*TT01S2*DSIGMA(L)                                          INIVER.64    
      SIG=SIGMAH(1)                                                        INIVER.65    
      IT=NL                                                                INIVER.66    
      DO 140 L=2,NL                                                        INIVER.67    
      TTKP=TKP(L)                                                          INIVER.68    
      TTM=TT01S2                                                           INIVER.69    
      SIGM=SIG                                                             INIVER.70    
      IF (L-NL) 70,80,80                                                   INIVER.71    
   70 TT01S2=T01S2(L)                                                      INIVER.72    
      SIG=SIGMAH(L)                                                        INIVER.73    
   80 RDSIGL=RDSIG(L)                                                      INIVER.74    
      DO 130 M=1,NL                                                        INIVER.75    
      IT=IT+1                                                              INIVER.76    
      IF (M-L) 90,100,110                                                  INIVER.77    
   90 TM=1.                                                                INIVER.78    
      TMM=1.                                                               INIVER.79    
      GOTO 120                                                             INIVER.80    
  100 TM=1.                                                                INIVER.81    
      TMM=0.                                                               INIVER.82    
      GOTO 120                                                             INIVER.83    
  110 TM=0.                                                                INIVER.84    
      TMM=0.                                                               INIVER.85    
  120 TTAU=TTM*(SIGM-TMM)                                                  INIVER.86    
      IF (L.LT.NL) TTAU=TTAU+TT01S2*(SIG-TM)                               INIVER.87    
      TTAU=TTAU*RDSIGL*DSIGMA(M)                                           INIVER.88    
      IF (M.LE.L) TTAU=TTAU+TTKP*C(IT)                                     INIVER.89    
  130 TAU(IT)=TTAU                                                         INIVER.90    
  140 CONTINUE                                                             INIVER.91    
C                                                                          INIVER.92    
C     RGG matrix for vertical derivatives:                                 INIVER.93    
C     d()/dln(sigma) = (sigma)d()/d(sigma).                                INIVER.94    
C                                                                          INIVER.95    
      IL=0                                                                 INIVER.96    
      DO 150 L=1,NL                                                        INIVER.97    
      RGVAL=SIGMA(L)*RDSIG(L)                                              INIVER.98    
      DO 150 M=1,NL                                                        INIVER.99    
      IL=IL+1                                                              INIVER.100   
      RGG(IL)=0.                                                           INIVER.101   
      IF (M.EQ.L-1) RGG(IL)=-RGVAL                                         INIVER.102   
      IF (M.EQ.L+1) RGG(IL)=RGVAL                                          INIVER.103   
  150 CONTINUE                                                             INIVER.104   
      DA=SIGMA(1)                                                          INIVER.105   
      DB=SIGMA(2)-DA                                                       INIVER.106   
      DC=SIGMA(3)-SIGMA(2)                                                 INIVER.107   
      DD=DC+DB                                                             INIVER.108   
      RGG(1)=-DA*(DD+DB)/(DB*DD)                                           INIVER.109   
      RGG(2)=DA*DD/(DB*DC)                                                 INIVER.110   
      RGG(3)=-DA*DB/(DC*DD)                                                INIVER.111   
      DA=SIGMA(NL)                                                         INIVER.112   
      DD=SIGMA(NL-1)                                                       INIVER.113   
      DB=DA-DD                                                             INIVER.114   
      DC=DD-SIGMA(NL-2)                                                    INIVER.115   
      DD=DC+DB                                                             INIVER.116   
      RGG(NL2)=DA*(DD+DB)/(DB*DD)                                          INIVER.117   
      RGG(NL2-1)=-DA*DD/(DB*DC)                                            INIVER.118   
      RGG(NL2-2)=DA*DB/(DC*DD)                                             INIVER.119   
C                                                                          INIVER.120   
      RETURN                                                               INIVER.121   
      END                                                                  INIVER.122   
C     ****************************************************************     INIVER.123   
*DECK INIUTF                                                               INIUTF.1     
      SUBROUTINE INIUTF(NAME,NCHAN)                                        INIUTF.2     
C                                                                          INIUTF.3     
C     UGAMP Transfer File, Version 1.4.                                    UTF14.12    
C     Initialise common block values and write global header.              INIUTF.5     
C                                                                          INIUTF.6     
*CALL PARAM1                                                               INIUTF.7     
*CALL PARAM2                                                               INIUTF.8     
*CALL BATS                                                                 INIUTF.10    
*CALL BLANK                                                                INIUTF.11    
*CALL COMPRL                                                               UTF14.13    
*CALL COMUTF                                                               UTF14.14    
*CALL OUTCON                                                               INIUTF.12    
      REAL ALOND(MG),ALEV(NL),ATIME(2)                                     UTF14.15    
      CHARACTER*8 NAME(2)                                                  UTF14.16    
C                                                                          UTF14.17    
C     Set up data for global header.                                       UTF14.18    
C                                                                          UTF14.19    
      DALON=360./REAL(MG*MOCT)                                             UTF14.20    
      DO 10 I=1,MG                                                         UTF14.21    
      ALOND(I)=REAL(I-1)*DALON                                             UTF14.22    
   10 CONTINUE                                                             UTF14.23    
C                                                                          UTF14.24    
C     Gaussian latitudes, omitting an equatorial row.                      UTF14.25    
C                                                                          UTF14.26    
      JTYP=0                                                               UTF14.27    
C                                                                          UTF14.28    
C     Level information in the global header is set to match that of       UTF14.29    
C     the zonal sections, dependent on LINTP3.                             UTF14.30    
C                                                                          UTF14.31    
      IF (LINTP3) THEN                                                     UTF14.32    
         LTYP=2                                                            UTF14.33    
         NLUTF=NLPR                                                        UTF14.34    
         DO 20 L=1,NLUTF                                                   UTF14.35    
            ALEV(L)=PLOUT(L)                                               UTF14.36    
   20    CONTINUE                                                          UTF14.37    
      ELSE                                                                 UTF14.38    
         LTYP=0                                                            UTF14.39    
         NLUTF=NL                                                          UTF14.40    
         DO 30 L=1,NLUTF                                                   UTF14.41    
            ALEV(L)=1000.*SIGMA(L)                                         UTF14.42    
   30    CONTINUE                                                          UTF14.43    
      ENDIF                                                                UTF14.44    
C                                                                          UTF14.45    
C     Time array contains beginning and end of time period.                UTF14.46    
C                                                                          UTF14.47    
      ITIM=2                                                               UTF14.48    
      BEGDAY=REAL(KSTART)/TSPD                                             UTF14.49    
      ENDDAY=REAL(KEND)/TSPD                                               UTF14.50    
      ATIME(1)=BEGDAY                                                      UTF14.51    
      ATIME(2)=ENDDAY                                                      UTF14.52    
C                                                                          UTF14.53    
      WRITE(CHT1,'(''RUN '',F8.3,5X,''DAYS '',F10.2,'' TO'',F10.2,5X)')    UTF14.54    
     :     RNTAPE,BEGDAY,ENDDAY                                            UTF14.55    
      WRITE(CHT2,'(2A8,34X)') (NAME(I),I=1,2)                              UTF14.56    
C                                                                          UTF14.57    
C     Write UTF global header.                                             UTF14.58    
C                                                                          UTF14.59    
      CALL UTFWI(MG,JG,NL,NHEM,MOCT,JTYP,LTYP,MM,NN,NWJ2                   UTF14.60    
     :          ,ITIM,0,0,0,0,IHR1)                                        UTF14.61    
      CALL U14WH(IHR1,ALOND,ALAT,ALEV,ATIME,CHT1,CHT2,NPCA)                UTF14.62    
C                                                                          UTF14.63    
C     Initialise field header character strings.                           UTF14.64    
C                                                                          UTF14.65    
      WRITE(CFR1,'(50X)')                                                  UTF14.66    
      WRITE(CFR2,'(50X)')                                                  UTF14.67    
      WRITE(CFR2D,'(''RUN '',F8.3,3X,''DAY'',32X)') RNTAPE                 UTF14.68    
      WRITE(CFR2T,'(''RUN '',F8.3,3X,''DAY'',F10.2,'' TO'',F10.2           UTF14.69    
     :              ,'' AVERAGE '')') RNTAPE,BEGDAY,ENDDAY                 UTF14.70    
C                                                                          INIUTF.85    
      RETURN                                                               INIUTF.86    
      END                                                                  INIUTF.87    
C     ****************************************************************     INIUTF.88    
*DECK INIROG                                                               INIROG.1     
      SUBROUTINE INIROG                                                    INIROG.2     
C                                                                          INIROG.3     
C     Read orography from channel NCROGS and optionally print/plot/dump.   BUGS5.1     
C     If JGL=1, write JG records to scratch channel NCROGG.                BUGS5.2     
C     If JGL=JG store all latitudes in /GRIDP/.                            INIROG.6     
C     NB.  Array GPV is equivalenced to spectral data in /SPECTR/.         INIROG.7     
C                                                                          INIROG.8     
*CALL PARAM1                                                               INIROG.9     
*CALL PARAM2                                                               INIROG.10    
*CALL BLANK                                                                INIROG.11    
*CALL COMFFT                                                               INIROG.12    
*CALL COMIOC                                                               INIROG.13    
*CALL COMMSK                                                               INIROG.14    
*CALL COMPRL                                                               INIROG.15    
*CALL COMROG                                                               INIROG.16    
*CALL GRIDP                                                                INIROG.18    
*CALL LEGAU                                                                INIROG.19    
*CALL OUTCON                                                               INIROG.20    
*CALL SPECTR                                                               INIROG.21    
      REAL GPV(IGC*JG),EGSG(IGC*JGL)                                       INIROG.22    
      EQUIVALENCE (GPV(1),Z(1)),(EGSG(1),GSG(1,1))                         INIROG.23    
      LOGICAL LAORF                                                        INIROG.24    
      CHARACTER*50 NAME                                                    INIROG.25    
C                                                                          INIROG.26    
      DATA NAME /'OROGRAPHIC HEIGHT                        METRES   '/     INIROG.27    
C                                                                          INIROG.28    
 6000 FORMAT(/' OROGRAPHY INCLUDED IN DIAGNOSTICS')                        INIROG.29    
 6010 FORMAT(/' ***INIROG: LAT-LONG OROGRAPHIC MASK NOT NEEDED:'           INIROG.30    
     :       ,' SWITCHED OFF')                                             INIROG.31    
 6020 FORMAT(/' ***INIROG: ZONAL MEAN OROGRAPHIC MASK NOT NEEDED:'         INIROG.32    
     :       ,' SWITCHED OFF')                                             INIROG.33    
 6030 FORMAT(/' OROGRAPHIC MASK PLOTTED ON ISOBARIC LAT-LONG FIELDS')      INIROG.34    
 6040 FORMAT(/' OROGRAPHIC MASK PLOTTED ON ISOBARIC ZONAL SECTIONS')       INIROG.35    
C                                                                          INIROG.36    
C     Preset spectral and grid point orography to zero.                    INIROG.37    
C                                                                          INIROG.38    
      DO 10 I=1,IGA                                                        INIROG.39    
   10 GS(I)=(0.,0.)                                                        INIROG.40    
      DO 20 I=1,IGC*JGL                                                    INIROG.41    
   20 EGSG(I)=0.                                                           INIROG.42    
C                                                                          INIROG.43    
C     Override namelist switches for orographic masks if required.         INIROG.44    
C                                                                          INIROG.45    
      LAORF=(KOUNTA.GT.0).OR.(KOUNTF.GT.0)                                 INIROG.46    
      IF (.NOT.(LPC2.AND.LROG.AND.LINTP2.AND.LAORF)) THEN                  INIROG.47    
         IF (LMSK2) WRITE(6,6010)                                          INIROG.48    
         LMSK2=.FALSE.                                                     SUNMOD.43    
      ENDIF                                                                INIROG.50    
      IF (.NOT.(LPC3.AND.LROG.AND.LINTP3.AND.LAORF)) THEN                  INIROG.51    
         IF (LMSK3) WRITE(6,6020)                                          INIROG.52    
         LMSK3=.FALSE.                                                     SUNMOD.44    
      ENDIF                                                                INIROG.54    
C                                                                          INIROG.55    
      IF (.NOT.LROG) RETURN                                                INIROG.56    
C                                                                          INIROG.57    
      WRITE(6,6000)                                                        INIROG.58    
      IF (LMSK2) WRITE(6,6030)                                             INIROG.59    
      IF (LMSK3) WRITE(6,6040)                                             INIROG.60    
C                                                                          INIROG.61    
C     Read spectral orography.  Replace this simple read as necessary.     INIROG.62    
C                                                                          INIROG.63    
      READ(NCROGS) GS                                                      INIROG.64    
C*ULC CALL READD(GS,-1,3*NL+1,NHEM,NN,NCROGS)                              INIROG.65    
C*RAL CALL READD(GS,MM-1,1,NHEM,NN,NCROGS)                                 INIROG.66    
C                                                                          INIROG.67    
C     Transform to grid point space.                                       INIROG.68    
C                                                                          INIROG.69    
      IF (JGL.EQ.1) THEN                                                   INIROG.70    
         REWIND NCROGG                                                     INIROG.71    
         REWIND NCLEG                                                      INIROG.72    
         JL=1                                                              INIROG.73    
         DO 30 IH=1,JG                                                     INIROG.74    
         READ(NCLEG) ALP                                                   INIROG.75    
         CALL HEXP(GS,GSG(1,JL),1,2)                                       INIROG.76    
         CALL FFT991(GSG(1,JL),WORK,TRIG,IFAX,1,MGPP,MG,NHEM,1)            INIROG.77    
         WRITE(NCROGG) GSG                                                 INIROG.78    
   30    JL=JL+JINC                                                        INIROG.79    
         REWIND NCROGG                                                     INIROG.80    
         REWIND NCLEG                                                      INIROG.81    
      ELSE                                                                 INIROG.82    
         NBATCH=(JGG-1)/NCRAY                                              INIROG.83    
         NREST=JGG-NBATCH*NCRAY                                            INIROG.84    
         JL=1                                                              INIROG.85    
         DO 40 IH=1,JG                                                     INIROG.86    
         CALL HEXP(GS,GSG(1,JL),1,2)                                       INIROG.87    
   40    JL=JL+JINC                                                        INIROG.88    
         IF (NBATCH.EQ.0) GOTO 60                                          INIROG.89    
         DO 50 N=1,NBATCH                                                  INIROG.90    
   50    CALL FFT991(EGSG(1+(N-1)*NCRAY*MGPP),WORK,TRIG                    INIROG.91    
     :              ,IFAX,1,MGPP,MG,NCRAY,1)                               INIROG.92    
   60    CALL FFT991(EGSG(1+NBATCH*NCRAY*MGPP),WORK,TRIG                   INIROG.93    
     :              ,IFAX,1,MGPP,MG,NREST,1)                               INIROG.94    
      ENDIF                                                                INIROG.95    
C                                                                          INIROG.96    
C     Print/plot/dump orography depending on switches in /COMROG/.         INIROG.97    
C     If JGL=JG copy GSG into GPV and call OUTSUB with NC<=0,              INIROG.98    
C     since the input array is modified by OUTSUB.                         INIROG.99    
C                                                                          INIROG.100   
      LOUTP=KOUNTP.GT.0                                                    INIROG.101   
      LOUTF=KOUNTF.GT.0                                                    INIROG.102   
      LOUTA=KOUNTA.GT.0                                                    INIROG.103   
      LOUT=(LOUTP.AND.LROGGR).OR.((LOUTA.OR.LOUTF).AND.LROGPL)             INIROG.104   
      IF (LOUT) THEN                                                       INIROG.105   
         IF (JGL.EQ.JG) THEN                                               INIROG.106   
            DO 70 I=1,IGC*JG                                               INIROG.107   
   70       GPV(I)=EGSG(I)                                                 INIROG.108   
         ENDIF                                                             INIROG.109   
         NC=NCROGG                                                         INIROG.110   
         IF (JGL.EQ.JG) NC=-1                                              INIROG.111   
         CALL OUTSUB(GPV,NAME,NC,1,CG/GA,ROGFAC,ROGINC,LROGGR,LROGPL       INIROG.112   
     :              ,IZGTYP,0,0)                                           INIROG.113   
      ENDIF                                                                INIROG.114   
C                                                                          INIROG.115   
      RETURN                                                               INIROG.116   
      END                                                                  INIROG.117   
C     ****************************************************************     INIROG.118   
*DECK READD                                                                READD.1     
      SUBROUTINE READD(GS,MZONAL,NLL,NOHEM,NND,IUNIT)                      READD.2     
C                                                                          READD.3     
C     Read spectral orography data (MZONAL=>0) from channel IUNIT          READD.4     
C     or skip records (MZONAL<0).                                          READD.5     
C     Routine by Paul Valdes for data in 'READD' format.                   READD.6     
C                                                                          READD.7     
*CALL PARAM1                                                               READD.8     
      COMPLEX GS(*),DUM                                                    READD.9     
C                                                                          READD.10    
      IGA=NWJ2*NOHEM                                                       READD.11    
C                                                                          READD.12    
      IF (MZONAL.GT.(NND-1)) THEN                                          READD.13    
         WRITE(6,'('' ***ABORT IN READD: MZONAL ERROR'')')                 READD.14    
         CALL ABORT                                                        READD.15    
      ENDIF                                                                READD.16    
C                                                                          READD.17    
      IF (MZONAL.LT.0) THEN                                                READD.18    
         MSKIP=NLL*NND                                                     READD.19    
         IF (MSKIP.GT.0) THEN                                              READD.20    
            DO 10 I=1,MSKIP                                                READD.21    
   10       READ(IUNIT)                                                    READD.22    
         ENDIF                                                             READD.23    
         RETURN                                                            READD.24    
      ENDIF                                                                READD.25    
C                                                                          READD.26    
      MSKIP=NND-1-MZONAL                                                   READD.27    
      DO 50 L=1,NLL                                                        READD.28    
      II=(L-1)*IGA                                                         READD.29    
      DO 30 M=0,MZONAL                                                     READD.30    
      N=(NN+1-M)/2                                                         READD.31    
      N1=(NND+1-M)/2                                                       READD.32    
      N2=MIN(N,N1)                                                         READD.33    
      NDUM=N1-N2                                                           READD.34    
      IF (NOHEM.EQ.1) THEN                                                 READD.35    
         READ(IUNIT) (GS(I),I=II+1,II+N2)                                  READD.36    
      ELSE                                                                 READD.37    
         IF (NDUM.LE.0) THEN                                               READD.38    
         READ(IUNIT) (GS(I),I=II+1,II+N2)                                  READD.39    
     :              ,(GS(I),I=II+NWJ2+1,II+NWJ2+N2)                        READD.40    
         ELSE                                                              READD.41    
            READ(IUNIT) (GS(I),I=II+1,II+N2),(DUM,I=1,NDUM)                READD.42    
     :                 ,(GS(I),I=II+NWJ2+1,II+NWJ2+N2)                     READD.43    
         ENDIF                                                             READD.44    
      ENDIF                                                                READD.45    
      IF (M.EQ.0) THEN                                                     READD.46    
         DO 20 IHEM=1,NOHEM                                                READD.47    
         I1=(IHEM-1)*NWJ2                                                  READD.48    
         DO 20 I=1,N2                                                      READD.49    
   20    GS(II+I+I1)=CMPLX(REAL(GS(II+I+I1)),0.)                           READD.50    
      ENDIF                                                                READD.51    
   30 II=II+N                                                              READD.52    
      IF (MZONAL.LT.(NND-1).AND.MSKIP.GT.0) THEN                           READD.53    
         DO 40 I=1,MSKIP                                                   READD.54    
   40    READ(IUNIT)                                                       READD.55    
      ENDIF                                                                READD.56    
   50 CONTINUE                                                             READD.57    
C                                                                          READD.58    
      RETURN                                                               READD.59    
      END                                                                  READD.60    
C     ****************************************************************     READD.61    
*DECK HEXRES                                                               HEXRES.1     
      SUBROUTINE HEXRES                                                    HEXRES.2     
C                                                                          HEXRES.3     
C     Performs indirect Legendre transform for the zonally symmetric       HEXRES.4     
C     restoration temperature field.  Gives grid point values (same as     HEXRES.5     
C     Fourier coefficients for m=0) from spectral coefficients.            HEXRES.6     
C                                                                          HEXRES.7     
*CALL PARAM1                                                               HEXRES.8     
*CALL PARAM2                                                               HEXRES.9     
      PARAMETER(NVRG=NL*NHEM)                                              HEXRES.10    
C                                                                          HEXRES.11    
*CALL BLANK                                                                HEXRES.12    
*CALL COMIOC                                                               HEXRES.13    
*CALL LEGAU                                                                HEXRES.14    
*CALL POLYNO                                                               HEXRES.15    
*CALL SPECTR                                                               HEXRES.16    
*CALL TAV                                                                  HEXRES.17    
      REAL GV(NVRG)                                                        HEXRES.18    
C                                                                          HEXRES.19    
C     Loop over latitude for transform to grid point space.                HEXRES.20    
C                                                                          HEXRES.21    
      IF (JGL.EQ.1) REWIND NCLEG                                           HEXRES.22    
      JL=1                                                                 HEXRES.23    
      DO 100 IH=1,JG                                                       HEXRES.24    
      IF (JGL.EQ.1) READ(NCLEG) ALP                                        HEXRES.25    
C                                                                          HEXRES.26    
C     Preset grid point array to zero.                                     HEXRES.27    
C                                                                          HEXRES.28    
      DO 10 I=1,NVRG                                                       HEXRES.29    
   10 GV(I)=0.                                                             HEXRES.30    
C                                                                          HEXRES.31    
C     Calculate POLY array in vector loop before main transform.           HEXRES.32    
C                                                                          HEXRES.33    
      ISPAR=0                                                              HEXRES.34    
      DO 20 IHEM=1,NHEM                                                    HEXRES.35    
      INC=(IHEM-1)*(1-ISPAR)+(2-IHEM)*ISPAR                                HEXRES.36    
      IA=INC-1                                                             HEXRES.37    
      DO 20 IN=1,IDM                                                       HEXRES.38    
      IA=IA+2                                                              HEXRES.39    
   20 POLY(IN,IHEM)=ALP(IA,JL)                                             HEXRES.40    
C                                                                          HEXRES.41    
C     Perform inverse Legendre transform from spectral space               HEXRES.42    
C     for m=0 only, giving the half-sum and half-difference                HEXRES.43    
C     of the north/south grid point values.                                HEXRES.44    
C     Separate code for NHEM=1,2 to increase efficiency.                   HEXRES.45    
C                                                                          HEXRES.46    
      IF (NHEM.EQ.1) THEN                                                  HEXRES.47    
         IP=-IDM                                                           HEXRES.48    
         DO 40 IN=1,IDM                                                    HEXRES.49    
         IP=IP+1                                                           HEXRES.50    
         DO 40 IV=1,NVRG                                                   HEXRES.51    
   40    GV(IV)=GV(IV) + POLY(IN,1)*TRES(IP+IV*IDM)                        HEXRES.52    
      ELSE                                                                 HEXRES.53    
         IP=-IDM                                                           HEXRES.54    
         DO 50 IN=1,IDM                                                    HEXRES.55    
         IP=IP+1                                                           HEXRES.56    
         DO 50 IV=1,NVRG                                                   HEXRES.57    
         II=IV-((IV-1)/NHEM)*NHEM                                          HEXRES.58    
   50    GV(IV)=GV(IV) + POLY(IN,II)*TRES(IP+IV*IDM)                       HEXRES.59    
      ENDIF                                                                HEXRES.60    
C                                                                          HEXRES.61    
C     For a global run, sum and difference even and odd contributions      HEXRES.62    
C     to give the grid point values at the northern and southern           HEXRES.63    
C     latitude rows.  Code assumes even symmetry:                          HEXRES.64    
C          IGPAR=0 : even (IA) precedes odd (IB).                          HEXRES.65    
C                                                                          HEXRES.66    
      IF (NHEM.EQ.2) THEN                                                  HEXRES.67    
         IA=-1                                                             HEXRES.68    
CDIR$ IVDEP                                                                HEXRES.69    
         DO 60 L=1,NL                                                      HEXRES.70    
         IA=IA+2                                                           HEXRES.71    
         IB=IA+1                                                           HEXRES.72    
         TEMP=GV(IA)                                                       HEXRES.73    
         GV(IA)=TEMP+GV(IB)                                                HEXRES.74    
   60    GV(IB)=TEMP-GV(IB)                                                HEXRES.75    
      ENDIF                                                                HEXRES.76    
C                                                                          HEXRES.77    
C     Set up zonal array of restoration temperatures, including TMEAN.     HEXRES.78    
C                                                                          HEXRES.79    
      DO 70 IHEM=1,NHEM                                                    HEXRES.80    
      I=IHEM                                                               HEXRES.81    
      IK=(3-2*IHEM)*IH+JGGP*(IHEM-1)                                       HEXRES.82    
      DO 70 L=1,NL                                                         HEXRES.83    
      TBRES(IK,L)=GV(I)+TMEAN(L)                                           HEXRES.84    
   70 I=I+NHEM                                                             HEXRES.85    
C                                                                          HEXRES.86    
  100 JL=JL+JINC                                                           HEXRES.87    
C                                                                          HEXRES.88    
      RETURN                                                               HEXRES.89    
      END                                                                  HEXRES.90    
C     ****************************************************************     HEXRES.91    
*DECK RCHECK                                                               RCHECK.1     
      SUBROUTINE RCHECK(NCHAN,RNTAPE,KOUNT,TSPD)                           RCHECK.2     
C                                                                          RCHECK.3     
C     Check label on next history record.  Skip forward to required        RCHECK.4     
C     analysis time if necessary, or abort if already passed.              RCHECK.5     
C                                                                          RCHECK.6     
 6900 FORMAT(/' ***ABORT IN RCHECK: RNTAPE CONFLICT ON READ')              RCHECK.7     
 6910 FORMAT(/' ***ABORT IN RCHECK: RKOUNT MISSED ON READ')                RCHECK.8     
 6920 FORMAT(/' ***ABORT IN RCHECK: EOF ENCOUNTERED')                      RCHECK.9     
 6990 FORMAT(/' PROGRAM VALUES:      KOUNT  RNTAPE DAY  =',I12,2F12.3      RCHECK.10    
     :       /' HISTORY FILE VALUES: RKOUNT RMTAPE RDAY =',3F12.3)         RCHECK.11    
C                                                                          RCHECK.12    
      DAY=REAL(KOUNT)/TSPD                                                 ANSI2.300   
C                                                                          RCHECK.14    
   10 READ(NCHAN,END=90) RKOUNT,RMTAPE,RDAY                                RCHECK.15    
      IF (ABS(RMTAPE-RNTAPE).GT.1.0E-10) THEN                              RCHECK.16    
         WRITE(6,6900)                                                     RCHECK.17    
         WRITE(6,6990) KOUNT,RNTAPE,DAY,RKOUNT,RMTAPE,RDAY                 RCHECK.18    
         CALL ABORT                                                        RCHECK.19    
      ENDIF                                                                RCHECK.20    
      MOUNT=NINT(RDAY*TSPD)                                                RCHECK.21    
      IF (MOUNT.LT.KOUNT) GOTO 10                                          RCHECK.22    
C                                                                          RCHECK.23    
      IF (MOUNT.GT.KOUNT) THEN                                             RCHECK.24    
         WRITE(6,6910)                                                     RCHECK.25    
         WRITE(6,6990) KOUNT,RNTAPE,DAY,RKOUNT,RMTAPE,RDAY                 RCHECK.26    
         CALL ABORT                                                        RCHECK.27    
      ENDIF                                                                RCHECK.28    
C                                                                          RCHECK.29    
      BACKSPACE NCHAN                                                      RCHECK.30    
      RETURN                                                               RCHECK.31    
C                                                                          RCHECK.32    
   90 WRITE(6,6920)                                                        RCHECK.33    
      WRITE(6,6990) KOUNT,RNTAPE,DAY,RKOUNT,RMTAPE,RDAY                    RCHECK.34    
      CALL ABORT                                                           RCHECK.35    
C                                                                          RCHECK.36    
      END                                                                  RCHECK.37    
C     ****************************************************************     RCHECK.38    
*DECK PHYSOP                                                               PHYSOP.1     
      SUBROUTINE PHYSOP                                                    PHYSOP.2     
C                                                                          PHYSOP.3     
C     Process 2-D surface fields of parameterisation diagnostics           PHYSOP.4     
C     at current analysis time.  Contained on JG records of history        PHYSOP.5     
C     file.  Skip and return if diagnostics not required.                  PHYSOP.6     
C                                                                          PHYSOP.7     
C     (NPH-1) instantaneous and daily-averaged fields are read, with       PHYSOP.8     
C     convective and large-scale rainfall rates last.  These are added     PHYSOP.9     
C     for the total rainfall in the (NPH)th field.                         PHYSOP.10    
C        NT=1 : instantaneous fields.                                      PHYSOP.11    
C        NT=2 : fields averaged over preceding KOUNTP steps in model.      PHYSOP.12    
C                                                                          PHYSOP.13    
C     NB.  Common SPECTR is used as workspace for GPV array.               PHYSOP.14    
C     NB.  Current code equivalences both the unused vector arrays GX      PHYSOP.15    
C     and GY to GVE( ,3) in common DUM, since GVE is only 3 fields long.   PHYSOP.16    
C                                                                          PHYSOP.17    
*CALL PARAM1                                                               PHYSOP.18    
*CALL PARAM2                                                               PHYSOP.19    
      PARAMETER(NCR=NPH-2,NLR=NPH-1)                                       ANSI2.301   
C                                                                          PHYSOP.21    
*CALL BATS                                                                 PHYSOP.22    
*CALL BLANK                                                                PHYSOP.23    
*CALL COMIOC                                                               PHYSOP.24    
*CALL COMMSK                                                               PHYSOP.25    
*CALL COMUTF                                                               UTF14.71    
*CALL DUM                                                                  PHYSOP.26    
*CALL LEGAU                                                                PHYSOP.28    
*CALL OUTCON                                                               PHYSOP.29    
*CALL SPECTR                                                               PHYSOP.30    
*CALL TIMFLX                                                               TMAV5.67    
      REAL GPV(MGPP,NHEM,JG,NPH,2)                                         PHYSOP.31    
      EQUIVALENCE (GPV(1,1,1,1,1),Z(1))                                    PHYSOP.32    
      REAL GV(MG,JGG,2),GX(MG,JGG),GY(MG,JGG)                              UTF14.72    
      EQUIVALENCE (GV,GVE(1,1)),(GX,GVE(1,3)),(GY,GVE(1,3))                PHYSOP.34    
      REAL DFAC(NPH),PHMN(NPH,2)                                           PHYSOP.35    
      LOGICAL LPRINT,LPLOT,LDUMP,LVEC,LFALSE                               UTF14.73    
      CHARACTER NAMES(NPH)*50,NAMC*50,TIMANN(2)*6                          UTF14.74    
      SAVE NAMES,TIMANN                                                    PHYSOP.40    
C                                                                          PHYSOP.41    
      DATA (NAMES(N),N=1,NPH)/                                             PHYSOP.42    
     1 'SURFACE STRESS                           N/M2     '                PHYSOP.43    
     2,'SURFACE HEAT FLUX                        W/M2     '                PHYSOP.44    
     3,'SURFACE LATENT FLUX                      W/M2     '                PHYSOP.45    
     4,'CONVECTIVE RAINFALL                      MM/DAY   '                PHYSOP.46    
     5,'LARGE SCALE RAINFALL                     MM/DAY   '                PHYSOP.47    
     6,'TOTAL RAINFALL                           MM/DAY   '                PHYSOP.48    
     :/                                                                    PHYSOP.49    
      DATA TIMANN/'(INST)','(AVER)'/                                       PHYSOP.50    
C                                                                          PHYSOP.51    
 6000 FORMAT(' PROCESSING SURFACE FIELDS    AT DAY',F10.2,' KOUNT=',I10)   PHYSOP.52    
 6010 FORMAT(/' DAY',F10.2,'  NUMBER OF TIMESTEPS COMPLETED =',I10)        PHYSOP.53    
 6900 FORMAT(' ***ABORT IN PHYSOP AT DAY',F10.2                            PHYSOP.54    
     :      ,' : LATITUDE COUNTER IN DATA =',I5,'  NOT',I5)                PHYSOP.55    
 6910 FORMAT( ' ***ABORT IN PHYSOP AT DAY',F10.2,'  RECORD NO',F10.2       BUGS4.74    
     :       /' ERROR READING HISTORY RECORD: RMTAPE RLTAPE=',2F20.12)     BUGS4.75    
C                                                                          PHYSOP.56    
C     Read JG records of 2D surface fields if output required at this      PHYSOP.57    
C     analysis time, or skip if not.                                       PHYSOP.58    
C     Daily-averaged fields precede instantaneous on history file.         PHYSOP.59    
C                                                                          PHYSOP.60    
      CALL RCHECK(NCHIST,RNTAPE,KOUNT,TSPD)                                PHYSOP.61    
      IF ((LPC7.AND.LOUT).OR.LPC9) THEN                                    PHYSOP.62    
         DO 10 J=1,JG                                                      PHYSOP.63    
         READ(NCHIST) RKOUNT,RMTAPE,DAY,RNR                                PHYSOP.64    
     :           ,((((GPV(I,IHEM,J,K,NT)                                   PHYSOP.65    
     :              ,I=1,MGPP),IHEM=1,NHEM),K=1,NLR),NT=2,1,-1)            PHYSOP.66    
     :           ,RLTAPE                                                   BUGS4.76    
         IF (NINT(RNR).NE.J) THEN                                          PHYSOP.68    
            WRITE(6,6900) DAY,NINT(RNR),J                                  PHYSOP.69    
            CALL ABORT                                                     PHYSOP.70    
         ENDIF                                                             PHYSOP.71    
         IF (RLTAPE.NE.RMTAPE) THEN                                        BUGS4.77    
            WRITE(6,6910) DAY,RNR,RMTAPE,RLTAPE                            BUGS4.78    
            CALL ABORT                                                     BUGS4.79    
         ENDIF                                                             BUGS4.80    
   10    CONTINUE                                                          PHYSOP.72    
      ELSE                                                                 PHYSOP.73    
         DO 20 J=1,JG                                                      PHYSOP.74    
   20    READ(NCHIST)                                                      PHYSOP.75    
         RETURN                                                            PHYSOP.76    
      ENDIF                                                                PHYSOP.77    
C                                                                          PHYSOP.78    
C     Write header and define dimensionalising factors and constants.      PHYSOP.79    
C                                                                          PHYSOP.80    
      IF (NPC7.NE.6) THEN                                                  PHYSOP.81    
         IF (LOUTP) WRITE(NPC7,'(///)')                                    PHYSOP.82    
         WRITE(NPC7,6000) DAY,KOUNT                                        PHYSOP.83    
      ENDIF                                                                PHYSOP.84    
      WRITE(6,6000) DAY,KOUNT                                              PHYSOP.85    
C                                                                          PHYSOP.86    
      DFAC(1)=P0                                                           PHYSOP.87    
      DFAC(2)=CV*P0                                                        PHYSOP.88    
      DFAC(3)=CV*P0                                                        PHYSOP.89    
      DFAC(4)=TSPD                                                         PHYSOP.90    
      DFAC(5)=TSPD                                                         PHYSOP.91    
      DFAC(6)=TSPD                                                         PHYSOP.92    
C                                                                          PHYSOP.93    
      IPTYP=IZGTYP                                                         PHYSOP.94    
      LVEC=.FALSE.                                                         SUNMOD.45    
      IMSK=0                                                               PHYSOP.96    
C                                                                          UTF14.75    
C     Prepare UTF header for current analysis time (or time average).      UTF14.76    
C                                                                          UTF14.77    
      IF (LOUTA) THEN                                                      UTF14.78    
         IF (DAY.GE.0) THEN                                                UTF14.79    
            WRITE(CFR2,'(A,F10.2,22X)') CFR2D(1:18),DAY                    UTF14.80    
         ELSE                                                              UTF14.81    
            CFR2=CFR2T                                                     UTF14.82    
         ENDIF                                                             UTF14.83    
      ENDIF                                                                UTF14.84    
C                                                                          PHYSOP.97    
C     Process data in main loops over fields.                              PHYSOP.98    
C     NT=1,2 for instantaneous then time-averaged fields.                  PHYSOP.99    
C     IOUT=1,NPH for individual fields, with special treatment for         PHYSOP.100   
C     rainfall fields.                                                     PHYSOP.101   
C     Also calculate global means in PHMN for routine PHYSAV.              PHYSOP.102   
C                                                                          PHYSOP.103   
      DO 200 NT=1,2                                                        PHYSOP.104   
      IF (LPC7.AND.LOUTP) WRITE(NPC7,6010) DAY,KOUNT                       PHYSOP.105   
C                                                                          PHYSOP.106   
      DO 50 IHEM=1,NHEM                                                    PHYSOP.107   
      DO 50 J=1,JG                                                         PHYSOP.108   
      DO 30 IOUT=1,NLR                                                     PHYSOP.109   
      DO 30 I=1,MG                                                         PHYSOP.110   
   30 GPV(I,IHEM,J,IOUT,NT)=GPV(I,IHEM,J,IOUT,NT)*DFAC(IOUT)               PHYSOP.111   
      DO 40 I=1,MGPP                                                       PHYSOP.112   
   40 GPV(I,IHEM,J,NPH,NT)=GPV(I,IHEM,J,NCR,NT)+GPV(I,IHEM,J,NLR,NT)       PHYSOP.113   
   50 CONTINUE                                                             PHYSOP.114   
C                                                                          PHYSOP.115   
      DO 100 IOUT=1,NPH                                                    PHYSOP.116   
      LPRINT=LOUTP.AND.LPHGR(IOUT)                                         PHYSOP.117   
      LPLOT =LOUTF.AND.LPHPL(IOUT)                                         PHYSOP.118   
      LDUMP =LOUTA.AND.LPHPL(IOUT)                                         PHYSOP.119   
      IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP.OR.LPC9)) GOTO 100                PHYSOP.120   
      N=1                                                                  PHYSOP.121   
      IFRAME=1                                                             PHYSOP.122   
      ICSTYL=0                                                             UTF14.85    
      IF (IOUT.EQ.NCR.AND.(LPLOT.OR.LDUMP).AND.LPHPL(NLR)) THEN            PHYSOP.123   
         ICSTYL=-1                                                         UTF14.86    
      ELSE IF (IOUT.EQ.NLR.AND.(LPLOT.OR.LDUMP).AND.LPHPL(NCR)) THEN       PHYSOP.125   
         N=2                                                               PHYSOP.126   
         IFRAME=0                                                          PHYSOP.127   
         ICSTYL=1                                                          UTF14.87    
      ENDIF                                                                PHYSOP.131   
      NAMES(IOUT)(25:30)=TIMANN(NT)                                        PHYSOP.132   
C                                                                          PHYSOP.133   
      DO 70 IHEM=1,NHEM                                                    PHYSOP.134   
      DO 70 J=1,JG                                                         PHYSOP.135   
      JJ=(2-IHEM)*J + (IHEM-1)*(JGGP-J)                                    UTF14.88    
      ZAV=0.                                                               UTF14.89    
      DO 60 I=1,MG                                                         UTF14.90    
      ZAV=ZAV+GPV(I,IHEM,J,IOUT,NT)                                        UTF14.91    
      GV(I,JJ,N)=GPV(I,IHEM,J,IOUT,NT)                                     UTF14.92    
   60 CONTINUE                                                             UTF14.93    
      GVZ(JJ,1)=ZAV*RMG                                                    UTF14.94    
   70 CONTINUE                                                             PHYSOP.141   
      IF (LPC9) PHMN(IOUT,NT)=SDOT(JGG,GVZ,1,GWT,1)                        PHYSOP.142   
      IF (.NOT.LDAILY) GOTO 100                                            TMAV5.68    
      IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP)) GOTO 100                        PHYSOP.143   
C                                                                          UTF14.95    
      CALL GPREP(GV(1,1,N),IGH,PHFAC(IOUT),PHINC(IOUT)                     UTF14.96    
     :           ,GNORM,GINC,ICNT,GMIN,GMAX,IFAIL)                         UTF14.97    
      IF (IFAIL.NE.0) CALL GFAIL(IFAIL,LPRINT,LPLOT,LDUMP,NAMES(IOUT)      UTF14.98    
     :                          ,ICNT)                                     UTF14.99    
C                                                                          UTF14.100   
      IF (LPRINT) THEN                                                     UTF14.101   
         LFALSE=.FALSE.                                                    UTF14.102   
         CALL GPRINT(GV(1,1,N),NAMES(IOUT),GMIN,GMAX,GNORM,NPC7)           UTF14.103   
         CALL XSECT(GVZ,1,NAMES(IOUT),NPC7,PHFAC(IOUT),0.                  UTF14.104   
     :             ,LPRINT,LFALSE,LFALSE,0,0,0)                            UTF14.105   
      ENDIF                                                                UTF14.106   
C                                                                          UTF14.107   
      IF (LDUMP) THEN                                                      UTF14.108   
         CALL UTFWI(MG,JGG,IPTYP,ICSTYL,0,0,IFRAME,0,IMSK,IASCII           UTF14.109   
     :             ,0,0,0,0,0,IFR3)                                        UTF14.110   
         CALL U14WF(GV(1,1,N),IFR3,NAMES(IOUT),CFR2,GMIN,GMAX,GINC,NPCA)   UTF14.111   
      ENDIF                                                                UTF14.112   
C                                                                          PHYSOP.170   
  100 CONTINUE                                                             PHYSOP.171   
  200 CONTINUE                                                             PHYSOP.172   
C                                                                          PHYSOP.173   
C     Write global means to channel NCGDG for output by routine PHYSAV     PHYSOP.174   
C     at end of run.                                                       PHYSOP.175   
C                                                                          PHYSOP.176   
      IF (.NOT.LPC9) RETURN                                                PHYSOP.177   
      WRITE(NCGDG) KOUNT,DAY                                               PHYSOP.178   
      WRITE(NCGDG) PHMN                                                    PHYSOP.179   
      IF (KOUNT.EQ.KEND) THEN                                              PHYSOP.180   
         JOUNT=-999                                                        PHYSOP.181   
         TDAY=-999.                                                        PHYSOP.182   
         WRITE(NCGDG) JOUNT,TDAY                                           PHYSOP.183   
      ENDIF                                                                PHYSOP.184   
C                                                                          PHYSOP.185   
      RETURN                                                               PHYSOP.186   
      END                                                                  PHYSOP.187   
C     ****************************************************************     PHYSOP.188   
*DECK PHYSEC                                                               PHYSEC.1     
      SUBROUTINE PHYSEC                                                    PHYSEC.2     
C                                                                          PHYSEC.3     
C     Process zonally averaged parameterisation tendencies at current      PHYSEC.4     
C     analysis time and increment time averages.  When called with         PHYSEC.5     
C     KOUNT < 0 at end of run, just output the time averaged fields.       PHYSEC.6     
C     N=1 for instantaneous values.                                        PHYSEC.7     
C     N=2 for values averaged over preceding KOUNTP model timesteps.       PHYSEC.8     
C     N=3 for time averages formed by accumulating N=2 values.             PHYSEC.9     
C                                                                          PHYSEC.10    
*CALL PARAM1                                                               PHYSEC.11    
*CALL PARAM2                                                               PHYSEC.12    
*CALL BATS                                                                 PHYSEC.13    
*CALL BLANK                                                                PHYSEC.14    
*CALL COMIOC                                                               PHYSEC.15    
*CALL LEGAU                                                                PHYSEC.17    
*CALL OUTCON                                                               PHYSEC.18    
*CALL PHYS                                                                 PHYSEC.19    
*CALL ZONAVP                                                               PHYSEC.20    
*CALL TIMFLX                                                               TMAV5.69    
      REAL PPZ(IGG,3,NXP),PPZEQ(3*IPPZ),DFAC(NXP)                          PHYSEC.21    
      EQUIVALENCE (PPZ(1,1,1),PPZEQ(1),UTVDZ(1,1))                         PHYSEC.22    
      LOGICAL LSW(NXP),LPH,LSTART,LPRINT,LPLOT,LDUMP                       UTF14.113   
      CHARACTER NAME(NXP)*50,TIMANN(3)*7                                   UTF14.114   
      SAVE NAME,TIMANN,DFAC,LSTART,LSW,LPH                                 PHYSEC.25    
C                                                                          PHYSEC.26    
      DATA (NAME(J),J=1,15)/                                               PHYSEC.27    
     1 'U-TEND VD                               M/S/DAY   '                UTF14.115   
     2,'V-TEND VD                               M/S/DAY   '                UTF14.116   
     3,'T-TEND VD                               K/DAY     '                UTF14.117   
     4,'Q-TEND VD                               G/KG/DAY  '                UTF14.118   
     5,'T-TEND CR                               K/DAY     '                UTF14.119   
     6,'Q-TEND CR                               G/KG/DAY  '                UTF14.120   
     7,'T-TEND LR                               K/DAY     '                UTF14.121   
     8,'Q-TEND LR                               G/KG/DAY  '                UTF14.122   
     9,'T-TEND RD                               K/DAY     '                UTF14.123   
     :,'U-TEND BL                               M/S/DAY   '                UTF14.124   
     1,'V-TEND BL                               M/S/DAY   '                UTF14.125   
     2,'T-TEND BL                               K/DAY     '                UTF14.126   
     3,'Q-TEND BL                               G/KG/DAY  '                UTF14.127   
     4,'U-TEND TOTAL                            M/S/DAY   '                UTF14.128   
     5,'V-TEND TOTAL                            M/S/DAY   '                UTF14.129   
     :/                                                                    PHYSEC.43    
      DATA (NAME(J),J=16,NXP)/                                             PHYSEC.44    
     6 'T-TEND TOTAL                            K/DAY     '                UTF14.130   
     7,'Q-TEND TOTAL                            G/KG/DAY  '                UTF14.131   
     8,'CONVECTION COUNTER                                '                UTF14.132   
     9,'LSR COUNTER                                       '                UTF14.133   
     :/                                                                    PHYSEC.49    
      DATA TIMANN/' (INST)',' (AVER)',' (TAV) '/                           PHYSEC.50    
      DATA LSTART/.TRUE./                                                  SUNMOD.47    
C                                                                          PHYSEC.52    
 6000 FORMAT(' PROCESSING PHYSICS Z-SECTS   AT DAY',F10.2,' KOUNT=',I10)   PHYSEC.53    
 6010 FORMAT(' PROCESSING PHYSICS Z-SECTS   FOR TIME AVERAGES')            PHYSEC.54    
 6900 FORMAT(' ***ABORT IN PHYSEC AT DAY',F10.2,                           PHYSEC.55    
     :       ' : RECORD COUNTER =',I5,'   NOT JGP')                        PHYSEC.56    
 6910 FORMAT( ' ***ABORT IN PHYSEC AT DAY',F10.2                           BUGS4.81    
     :       /' ERROR READING HISTORY RECORD: RMTAPE RLTAPE=',2F20.12)     BUGS4.82    
C                                                                          PHYSEC.57    
C     On first call set up and save switches and factors and preset PPZ.   PHYSEC.58    
C                                                                          PHYSEC.59    
      IF (LSTART) THEN                                                     PHYSEC.60    
         LPH=LVD.OR.LCR.OR.LLR.OR.LRD.OR.LBL                               PHYSEC.61    
         CVT=PI2*CV                                                        PHYSEC.62    
         CQT=PI2*CQ                                                        PHYSEC.63    
         DFAC(1)=CVT                                                       PHYSEC.64    
         DFAC(2)=CVT                                                       PHYSEC.65    
         DFAC(3)=CTT                                                       PHYSEC.66    
         DFAC(4)=CQT                                                       PHYSEC.67    
         DFAC(5)=CTT                                                       PHYSEC.68    
         DFAC(6)=CQT                                                       PHYSEC.69    
         DFAC(7)=CTT                                                       PHYSEC.70    
         DFAC(8)=CQT                                                       PHYSEC.71    
         DFAC(9)=CTT                                                       PHYSEC.72    
         DFAC(10)=CVT                                                      PHYSEC.73    
         DFAC(11)=CVT                                                      PHYSEC.74    
         DFAC(12)=CTT                                                      PHYSEC.75    
         DFAC(13)=CQT                                                      PHYSEC.76    
         DFAC(14)=CVT                                                      PHYSEC.77    
         DFAC(15)=CVT                                                      PHYSEC.78    
         DFAC(16)=CTT                                                      PHYSEC.79    
         DFAC(17)=CQT                                                      PHYSEC.80    
         DFAC(18)=1                                                        PHYSEC.81    
         DFAC(19)=1                                                        PHYSEC.82    
         DO 10 IOUT=1,4                                                    PHYSEC.83    
   10    LSW(IOUT)=LVD                                                     PHYSEC.84    
         LSW(  5 )=LCR                                                     PHYSEC.85    
         LSW(  6 )=LCR                                                     PHYSEC.86    
         LSW(  7 )=LLR                                                     PHYSEC.87    
         LSW(  8 )=LLR                                                     PHYSEC.88    
         LSW(  9 )=LRD                                                     PHYSEC.89    
         DO 20 IOUT=10,13                                                  PHYSEC.90    
   20    LSW(IOUT)=LBL                                                     PHYSEC.91    
         LSW( 14 )=LVD.AND.LBL                                             PHYSEC.92    
         LSW( 15 )=LVD.AND.LBL                                             PHYSEC.93    
         LSW( 16 )=.TRUE.                                                  SUNMOD.48    
         LSW( 17 )=.TRUE.                                                  SUNMOD.49    
         LSW( 18 )=LCR                                                     PHYSEC.96    
         LSW( 19 )=LLR                                                     PHYSEC.97    
         DO 30 I=1,3*IPPZ                                                  PHYSEC.98    
   30    PPZEQ(I)=0.                                                       PHYSEC.99    
         LSTART=.FALSE.                                                    SUNMOD.50    
      ENDIF                                                                PHYSEC.101   
       LTYP=0                                                              UTF14.134   
C                                                                          PHYSEC.103   
C     Read data at current analysis time if KOUNT >= 0.                    PHYSEC.104   
C     Check switches and return if no output required.                     PHYSEC.105   
C                                                                          PHYSEC.106   
      IF (KOUNT.GE.0) THEN                                                 PHYSEC.107   
         CALL RCHECK(NCHIST,RNTAPE,KOUNT,TSPD)                             PHYSEC.108   
         IF (LPC8.AND.LPH.AND.(LTAV.OR.LOUT)) THEN                         PHYSEC.109   
            INL=NLM*JGG+1                                                  PHYSEC.110   
            READ(NCHIST) RKOUNT,RMTAPE,DAY,RNR                             PHYSEC.111   
     :       ,((UTVDZ(I,N),I=1,IGG),(VTVDZ(I,N),I=1,IGG)                   PHYSEC.112   
     :        ,(TTVDZ(I,N),I=1,IGG),(QTVDZ(I,N),I=1,IGG)                   PHYSEC.113   
     :        ,(TTCRZ(I,N),I=1,IGG),(QTCRZ(I,N),I=1,IGG)                   PHYSEC.114   
     :        ,(TTLRZ(I,N),I=1,IGG),(QTLRZ(I,N),I=1,IGG)                   PHYSEC.115   
     :        ,(TTRDZ(I,N),I=1,IGG)                                        PHYSEC.116   
     :        ,(CTCRZ(I,N),I=1,IGG),(CTLRZ(I,N),I=1,IGG)                   PHYSEC.117   
     :        ,(UTBLZ(I,N),I=INL,IGG),(VTBLZ(I,N),I=INL,IGG)               PHYSEC.118   
     :        ,(TTBLZ(I,N),I=INL,IGG),(QTBLZ(I,N),I=INL,IGG)               PHYSEC.119   
     :        ,N=2,1,-1),RLTAPE                                            BUGS4.83    
            IF (NINT(RNR).NE.JGP) THEN                                     PHYSEC.121   
               WRITE(6,6900) DAY,NINT(RNR)                                 PHYSEC.122   
               CALL ABORT                                                  PHYSEC.123   
            ENDIF                                                          PHYSEC.124   
            IF (RLTAPE.NE.RMTAPE) THEN                                     BUGS4.84    
               WRITE(6,6910) DAY,RMTAPE,RLTAPE                             BUGS4.85    
               CALL ABORT                                                  BUGS4.86    
            ENDIF                                                          BUGS4.87    
         ELSE                                                              PHYSEC.125   
            READ(NCHIST)                                                   PHYSEC.126   
            RETURN                                                         PHYSEC.127   
         ENDIF                                                             PHYSEC.128   
      ELSE                                                                 PHYSEC.129   
         IF (.NOT.(LPC8.AND.LPH.AND.LTAV.AND.LOUT)) RETURN                 PHYSEC.130   
      ENDIF                                                                PHYSEC.131   
C                                                                          PHYSEC.132   
C     Write header.  Set up loop limits for current time or averages.      PHYSEC.133   
C                                                                          PHYSEC.134   
      IF (LOUTP.AND.NPC8.NE.6) WRITE(NPC8,'(///)')                         PHYSEC.135   
      IF (KOUNT.GE.0) THEN                                                 PHYSEC.136   
         NMIN=1                                                            PHYSEC.137   
         NMAX=2                                                            PHYSEC.138   
         IF (NPC8.NE.6) WRITE(NPC8,6000) DAY,KOUNT                         PHYSEC.139   
         WRITE(6,6000) DAY,KOUNT                                           PHYSEC.140   
      ELSE                                                                 PHYSEC.141   
         NMIN=3                                                            PHYSEC.142   
         NMAX=3                                                            PHYSEC.143   
         IF (NPC2.NE.6) WRITE(NPC8,6010)                                   PHYSEC.144   
         WRITE(6,6010)                                                     PHYSEC.145   
      ENDIF                                                                PHYSEC.146   
C                                                                          PHYSEC.147   
C     Process data.                                                        PHYSEC.148   
C                                                                          PHYSEC.149   
      DO 200 N=NMIN,NMAX                                                   PHYSEC.150   
      IF (KOUNT.GE.0) THEN                                                 PHYSEC.151   
         DO 100 L=1,NL                                                     PHYSEC.152   
         IOF=(L-1)*JGG                                                     PHYSEC.153   
         DO 100 J=1,JGG                                                    PHYSEC.154   
         I=IOF+J                                                           PHYSEC.155   
         UTVDZ(I,N)=UTVDZ(I,N)/CS(J)                                       PHYSEC.156   
         VTVDZ(I,N)=VTVDZ(I,N)/CS(J)                                       PHYSEC.157   
         UTBLZ(I,N)=UTBLZ(I,N)/CS(J)                                       PHYSEC.158   
  100    VTBLZ(I,N)=VTBLZ(I,N)/CS(J)                                       PHYSEC.159   
         DO 110 I=1,IGG                                                    PHYSEC.160   
         UTOTZ(I,N)=UTBLZ(I,N)+UTVDZ(I,N)                                  PHYSEC.161   
         VTOTZ(I,N)=VTBLZ(I,N)+VTVDZ(I,N)                                  PHYSEC.162   
         TTOTZ(I,N)=TTBLZ(I,N)+TTVDZ(I,N)+TTCRZ(I,N)+TTLRZ(I,N)            PHYSEC.163   
     :             +TTRDZ(I,N)                                             PHYSEC.164   
  110    QTOTZ(I,N)=QTBLZ(I,N)+QTVDZ(I,N)+QTCRZ(I,N)+QTLRZ(I,N)            PHYSEC.165   
         IF (LTAV.AND.KOUNT.GT.KSTART.AND.N.EQ.2) THEN                     PHYSEC.166   
            DO 120 IOUT=1,NXP                                              PHYSEC.167   
            DO 120 I=1,IGG                                                 PHYSEC.168   
  120       PPZ(I,3,IOUT)=PPZ(I,3,IOUT)+FTAV*PPZ(I,2,IOUT)                 PHYSEC.169   
         ENDIF                                                             PHYSEC.170   
      ENDIF                                                                PHYSEC.171   
      IF (N.LE.2.AND..NOT.LDAILY) GOTO 200                                 TMAV5.70    
      DO 150 IOUT=1,NXP                                                    PHYSEC.172   
      LPRINT=LOUTP.AND.LSW(IOUT).AND.LXPGR(IOUT)                           PHYSEC.173   
      LPLOT =LOUTF.AND.LSW(IOUT).AND.LXPPL(IOUT).AND.(N.NE.2)              PHYSEC.174   
      LDUMP =LOUTA.AND.LSW(IOUT).AND.LXPPL(IOUT).AND.(N.NE.2)              PHYSEC.175   
      IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP)) GOTO 150                        PHYSEC.176   
      DO 130 I=1,IGG                                                       PHYSEC.177   
  130 PPZ(I,N,IOUT)=PPZ(I,N,IOUT)*DFAC(IOUT)                               PHYSEC.178   
      NAME(IOUT)(21:27)=TIMANN(N)                                          PHYSEC.179   
      ICSTYL=0                                                             UTF14.135   
      CALL XSECT(PPZ(1,N,IOUT),NL,NAME(IOUT),NPC8,XPFAC(IOUT)              UTF14.136   
     :          ,XPINC(IOUT),LPRINT,LPLOT,LDUMP,ICSTYL,LTYP,0)             UTF14.137   
      DO 140 I=1,IGG                                                       UTF14.138   
      PPZ(I,N,IOUT)=PPZ(I,N,IOUT)/DFAC(IOUT)                               UTF14.139   
  140 CONTINUE                                                             UTF14.140   
  150 CONTINUE                                                             PHYSEC.185   
  200 CONTINUE                                                             PHYSEC.186   
C                                                                          PHYSEC.187   
      RETURN                                                               PHYSEC.188   
      END                                                                  PHYSEC.189   
C     ****************************************************************     PHYSEC.190   
*DECK PHYSAV                                                               PHYSAV.1     
      SUBROUTINE PHYSAV                                                    PHYSAV.2     
C                                                                          PHYSAV.3     
C     Process time series and time averages of globally averaged           PHYSAV.4     
C     parameterisation diagnostics.  These have been accumulated           PHYSAV.5     
C     on channel NCGDG by routine PHYSOP at each analysis time.            PHYSAV.6     
C     PHMN(K,1) contains instantaneous values.                             PHYSAV.7     
C     PHMN(K,2) contains values averaged over previous KOUNTP steps.       PHYSAV.8     
C     PHMN(K,3) contains time averages over entire run using the           PHYSAV.9     
C               PHMN(K,2) values, so omitting KSTART.                      PHYSAV.10    
C     NB.  Time averages are for period KSTART to KEND, irrespective       PHYSAV.11    
C     of whether parameterisations active from KBEGP > KSTART.             PHYSAV.12    
C     NB.  PHYSAV must only be called after final call to GDIAG, since     PHYSAV.13    
C     the time series array ADIAG is equivalenced to an array in           PHYSAV.14    
C     common SERIES used by GDIAG.                                         PHYSAV.15    
C                                                                          PHYSAV.16    
*CALL PARAM1                                                               PHYSAV.17    
*CALL PARAM2                                                               PHYSAV.18    
*CALL BATS                                                                 PHYSAV.19    
*CALL BLANK                                                                PHYSAV.20    
*CALL COMIOC                                                               PHYSAV.21    
*CALL OUTCON                                                               PHYSAV.22    
*CALL PHYS                                                                 PHYSAV.23    
*CALL SERIES                                                               PHYSAV.24    
      REAL PHMN(NPH,3),ADIAG(NPMAX9,8)                                     GAVPLT1.1     
      CHARACTER IYLAB(3)*30,IDAN(8)*3,TIMANN(3)*7                          GAVPLT1.2     
      EQUIVALENCE (ADIAG(1,1),ACONV(1,1))                                  PHYSAV.28    
C                                                                          PHYSAV.29    
      DATA IYLAB/'         SURFACE STRESS N/M2*.'                          PHYSAV.32    
     :,          '         SURFACE FLUXES W/M2*.'                          PHYSAV.33    
     :,          '         PRECIP/EVAP MM/DAY*.'                           PHYSAV.34    
     :/                                                                    PHYSAV.35    
      DATA IDAN /'TAU','  H','  L','  R',' CR',' LR','  R','  E'/          PHYSAV.37    
      DATA TIMANN/'(INST) ','(AVER) ',' (TAV) '/                           PHYSAV.38    
C                                                                          PHYSAV.39    
 6000 FORMAT(' GLOBAL SURFACE DIAGNOSTICS AT DAY ',F6.2)                   PHYSAV.40    
 6010 FORMAT(' TIME AVERAGE GLOBAL SURFACE DIAGNOSTICS')                   PHYSAV.41    
 6020 FORMAT(1P,5X,A,'  HFLUX=',E12.5,'  LFLUX=',E12.5                     PHYSAV.42    
     :              ,' PRECIP=',E12.5,' W/M2   STRESS=',E12.5,' N/M2')     PHYSAV.43    
 6030 FORMAT(1P,5X,A,'  CRAIN=',E12.5,'  LRAIN=',E12.5                     PHYSAV.44    
     :              ,'   RAIN=',E12.5,'   EVAP=',E12.5,' MM/DAY')          PHYSAV.45    
 6040 FORMAT(' ***PHYSAV : TIME SERIES OF PHYSICS GLOBAL AVERAGES'         PHYSAV.46    
     :      ,' ON PLOT FILE STOPS AT DAY',F10.2)                           PHYSAV.47    
 6050 FORMAT('#',/'# GLOBAL DIAGNOSTICS TIME SERIES RUNS FROM DAY '        GAVPLT1.3     
     :      ,F10.2,' TO DAY ',F10.2)                                       GAVPLT1.4     
C                                                                          PHYSAV.48    
C     Write header.  Preset time averages and set constants.               PHYSAV.49    
C                                                                          PHYSAV.50    
      IF (NPC9.NE.6) WRITE(NPC9,'(/////)')                                 PHYSAV.51    
      WRITE(6,'(/////)')                                                   PHYSAV.52    
      IF (LTAV) THEN                                                       PHYSAV.53    
         DO 10 K=1,NPH                                                     PHYSAV.54    
   10    PHMN(K,3)=0.                                                      PHYSAV.55    
      ENDIF                                                                PHYSAV.56    
      RTOF=WW*CLATNT*.001*1000./PI2                                        PHYSAV.57    
      REWIND NCGDG                                                         PHYSAV.58    
      NPTS9=0                                                              PHYSAV.59    
C                                                                          PHYSAV.60    
C     ----------------------------------------------------------------     PHYSAV.61    
C     Main loop over analysis times.  For JOUNT >= 0 read data from        PHYSAV.62    
C     channel NCGDG.  JOUNT<0 denotes end of series so process averages.   PHYSAV.63    
C                                                                          PHYSAV.64    
   20 READ(NCGDG) JOUNT,TDAY                                               PHYSAV.65    
      IF (JOUNT.EQ.-999.AND..NOT.LTAV) RETURN                              PHYSAV.66    
C                                                                          PHYSAV.67    
      IF (JOUNT.GE.0) THEN                                                 PHYSAV.68    
         IF (NPC9.NE.6) WRITE(NPC9,6000) TDAY                              PHYSAV.69    
         WRITE(6,6000) TDAY                                                PHYSAV.70    
         READ(NCGDG) ((PHMN(K,N),K=1,NPH),N=1,2)                           PHYSAV.71    
         IF (LTAV.AND.JOUNT.GT.KSTART) THEN                                PHYSAV.72    
            DO 30 K=1,NPH                                                  PHYSAV.73    
   30       PHMN(K,3)=PHMN(K,3)+FTAV*PHMN(K,2)                             PHYSAV.74    
         ENDIF                                                             PHYSAV.75    
         NMIN=1                                                            PHYSAV.76    
         NMAX=2                                                            PHYSAV.77    
      ELSE                                                                 PHYSAV.78    
         IF (NPC9.NE.6) WRITE(NPC9,6010)                                   PHYSAV.79    
         WRITE(6,6010)                                                     PHYSAV.80    
         NMIN=3                                                            PHYSAV.81    
         NMAX=3                                                            PHYSAV.82    
      ENDIF                                                                PHYSAV.83    
C                                                                          PHYSAV.84    
      DO 40 N=NMIN,NMAX                                                    PHYSAV.85    
      SSBL=PHMN(1,N)                                                       PHYSAV.86    
      SHBL=PHMN(2,N)                                                       PHYSAV.87    
      SLBL=PHMN(3,N)                                                       PHYSAV.88    
      RRCR=PHMN(4,N)                                                       PHYSAV.89    
      RRLR=PHMN(5,N)                                                       PHYSAV.90    
      RAIN=PHMN(6,N)                                                       PHYSAV.91    
      PREC=RAIN*RTOF                                                       PHYSAV.92    
      EVAP=SLBL/RTOF                                                       PHYSAV.93    
      IF (NPC9.NE.6) THEN                                                  PHYSAV.94    
         WRITE(NPC9,6020) TIMANN(N),SHBL,SLBL,PREC,SSBL                    PHYSAV.95    
         WRITE(NPC9,6030) TIMANN(N),RRCR,RRLR,RAIN,EVAP                    PHYSAV.96    
      ENDIF                                                                PHYSAV.97    
      WRITE(6,6020) TIMANN(N),SHBL,SLBL,PREC,SSBL                          PHYSAV.98    
      WRITE(6,6030) TIMANN(N),RRCR,RRLR,RAIN,EVAP                          PHYSAV.99    
   40 CONTINUE                                                             PHYSAV.100   
      IF (JOUNT.LT.0) GOTO 50                                              PHYSAV.101   
C                                                                          PHYSAV.102   
C     Copy values into time series array to be sorted and copied to        PHYSAV.103   
C     plot file below.                                                     PHYSAV.104   
C                                                                          PHYSAV.105   
      IF (LPHCOP.AND.NPTS9.LT.NPMAX9) THEN                                 PHYSAV.106   
         NPTS9=NPTS9+1                                                     PHYSAV.107   
         IF (NPTS9.EQ.NPMAX9) WRITE(6,6040) TDAY                           BUGS2.3     
         ADAY(NPTS9)=TDAY                                                  BUGS2.4     
         ADIAG(NPTS9,1)=PHMN(1,2)                                          PHYSAV.110   
         ADIAG(NPTS9,2)=PHMN(2,2)                                          PHYSAV.111   
         ADIAG(NPTS9,3)=PHMN(3,2)                                          PHYSAV.112   
         ADIAG(NPTS9,5)=PHMN(4,2)                                          PHYSAV.113   
         ADIAG(NPTS9,6)=PHMN(5,2)                                          PHYSAV.114   
         ADIAG(NPTS9,7)=PHMN(6,2)                                          PHYSAV.115   
         ADIAG(NPTS9,4)=ADIAG(NPTS9,7)*RTOF                                PHYSAV.116   
         ADIAG(NPTS9,8)=ADIAG(NPTS9,3)/RTOF                                PHYSAV.117   
      ENDIF                                                                PHYSAV.118   
C                                                                          PHYSAV.119   
      GOTO 20                                                              PHYSAV.120   
C                                                                          PHYSAV.121   
C     ----------------------------------------------------------------     PHYSAV.122   
C     End of loop over analysis times.                                     PHYSAV.123   
C     Write time series to file for plotting in subsequent job.            PHYSAV.124   
C                                                                          PHYSAV.125   
   50 IF (.NOT.LPHCOP) RETURN                                              PHYSAV.126   
      IF (NPC9.NE.6) WRITE(NPC9,6050) ADAY(1),ADAY(NPTS9)                  GAVPLT1.5     
      WRITE(6,6050) ADAY(1),ADAY(NPTS9)                                    GAVPLT1.6     
      WRITE(NCPLOT(1),6050)  ADAY(1),ADAY(NPTS9)                           GAVPLT1.7     
C                                                                          GAVPLT1.8     
C     Surface stress.                                                      GAVPLT1.9     
C                                                                          GAVPLT1.10    
      WRITE(IYLAB(1)(1:8),'(F8.3)') RNTAPE                                 GAVPLT1.11    
      WRITE(NCPLOT(1),'(''#'',A)') IYLAB(1)                                GAVPLT1.12    
      WRITE(NCPLOT(1),'(''#'',2(4X,A,3X))') 'DAY',IDAN(1)                  GAVPLT1.13    
      DO 110 N=1,NPTS9                                                     GAVPLT1.14    
      WRITE(NCPLOT(1),'(2F10.4)') ADAY(N),ADIAG(N,1)                       GAVPLT1.15    
  110 CONTINUE                                                             GAVPLT1.16    
C                                                                          GAVPLT1.17    
C     Surface fluxes and pptn in W/m2.                                     GAVPLT1.18    
C                                                                          GAVPLT1.19    
      WRITE(IYLAB(2)(1:8),'(F8.3)') RNTAPE                                 GAVPLT1.20    
      WRITE(NCPLOT(1),'(''#'',A)') IYLAB(2)                                GAVPLT1.21    
      WRITE(NCPLOT(1),'(''#'',4(4X,A,3X))') 'DAY',(IDAN(I),I=2,4)          GAVPLT1.22    
      DO 120 N=1,NPTS9                                                     GAVPLT1.23    
      WRITE(NCPLOT(1),'(4F10.4)') ADAY(N),(ADIAG(N,I),I=2,4)               GAVPLT1.24    
  120 CONTINUE                                                             GAVPLT1.25    
C                                                                          GAVPLT1.26    
C     Precipitation (inc. components) and evaporation in mm/day.           GAVPLT1.27    
C                                                                          GAVPLT1.28    
      WRITE(IYLAB(3)(1:8),'(F8.3)') RNTAPE                                 GAVPLT1.29    
      WRITE(NCPLOT(1),'(''#'',A)') IYLAB(3)                                GAVPLT1.30    
      WRITE(NCPLOT(1),'(''#'',5(4X,A,3X))') 'DAY',(IDAN(I),I=5,8)          GAVPLT1.31    
      DO 130 N=1,NPTS9                                                     GAVPLT1.32    
      WRITE(NCPLOT(1),'(5F10.4)') ADAY(N),(ADIAG(N,I),I=5,8)               GAVPLT1.33    
  130 CONTINUE                                                             GAVPLT1.34    
C                                                                          PHYSAV.157   
      RETURN                                                               PHYSAV.158   
      END                                                                  PHYSAV.159   
C     ****************************************************************     PHYSAV.160   
*DECK LTEND                                                                LTEND.1     
      SUBROUTINE LTEND                                                     LTEND.2     
C                                                                          LTEND.3     
C     Calculate diabatic/frictional tendencies from linear processes.      LTEND.4     
C     Biharmonic diffusion : Restoration : Linear Drag.                    LTEND.5     
C                                                                          LTEND.6     
*CALL PARAM1                                                               LTEND.7     
*CALL PARAM2                                                               LTEND.8     
*CALL BATS                                                                 LTEND.9     
*CALL BLANK                                                                LTEND.10    
*CALL COMGEN                                                               LTEND.11    
*CALL SPECTR                                                               LTEND.12    
C                                                                          LTEND.13    
      DO 10 I=1,IGB,IGA                                                    LTEND.14    
   10 Z(I)=Z(I)-EZ                                                         LTEND.15    
C                                                                          LTEND.16    
      IG=0                                                                 LTEND.17    
      I=0                                                                  LTEND.18    
      DO 50 L=1,NL                                                         LTEND.19    
      TIDZT=0.                                                             LTEND.20    
      TIGZT=0.                                                             LTEND.21    
      TRKZT=0.                                                             LTEND.22    
      TRNZT=0.                                                             LTEND.23    
      TIDET=0.                                                             LTEND.24    
      TIGET=0.                                                             LTEND.25    
      TRNST=0.                                                             LTEND.26    
      TDRZT=0.                                                             LTEND.27    
      TDRET=0.                                                             LTEND.28    
      DO 40 IHEM=1,NHEM                                                    LTEND.29    
      JE=IHEM-1                                                            LTEND.30    
      JO=2-IHEM                                                            LTEND.31    
      IF (IHEM.EQ.1) TRNST=TRNST+REAL(T(IG+1)*(T(IG+1)-TRES(I+1)))         LTEND.32    
      DO 20 JP=1,NFP,MH                                                    LTEND.33    
      I=I+1                                                                LTEND.34    
      IG=IG+1                                                              LTEND.35    
      TIDZT=TIDZT+REAL(D(IG)*D(IG))*(SQ(JP+JE)**NDELHM)+REAL(Z(IG)*Z(IG)   LTEND.36    
     :)*(SQ(JP+JO)**NDELHM)                                                LTEND.37    
      TDRZT=TDRZT+REAL(D(IG)*D(IG))*DRAG(L)*RSQ(JP+JE)                     LTEND.38    
     :+REAL(Z(IG)*Z(IG))*DRAG(L)*RSQ(JP+JO)                                LTEND.39    
      TIGZT=TIGZT+REAL(T(IG)*T(IG))*(SQ(JP+JE)**NDELH)                     LTEND.40    
      TRNZT=TRNZT+REAL(T(IG)*(T(IG)-TRES(I)))                              LTEND.41    
   20 CONTINUE                                                             LTEND.42    
      DO 30 MP=MOCTP,MFP,MOCT                                              LTEND.43    
      DO 30 JP=MP,NFP,MH                                                   LTEND.44    
      IG=IG+1                                                              LTEND.45    
      TIDET=TIDET+REAL(D(IG)*CONJG(D(IG)))*(SQ(JP+JE)**NDELHM)+REAL(       LTEND.46    
     :Z(IG)*CONJG(Z(IG)))*(SQ(JP+JO)**NDELHM)                              LTEND.47    
      TDRET=TDRET+REAL(D(IG)*CONJG(D(IG)))*DRAG(L)*RSQ(JP+JE)              LTEND.48    
     :+REAL(Z(IG)*CONJG(Z(IG)))*DRAG(L)*RSQ(JP+JO)                         LTEND.49    
      TIGET=TIGET+REAL(T(IG)*CONJG(T(IG)))*(SQ(JP+JE)**NDELH)              LTEND.50    
   30 CONTINUE                                                             LTEND.51    
   40 CONTINUE                                                             LTEND.52    
      TIDZ(L)=.5*TIDZT                                                     LTEND.53    
      TIGZ(L)=.5*TIGZT                                                     LTEND.54    
      TRKZ(L)=.5*TRKZT                                                     LTEND.55    
      TRNZ(L)=.5*(TRNZT-TRNST)                                             LTEND.56    
      TRNS(L)=.5*TRNST                                                     LTEND.57    
      TDRZ(L)=.5*TDRZT                                                     LTEND.58    
      TDRE(L)=TDRET                                                        LTEND.59    
      TIDE(L)=TIDET                                                        LTEND.60    
      TIGE(L)=TIGET                                                        LTEND.61    
   50 CONTINUE                                                             LTEND.62    
C                                                                          LTEND.63    
      DO 60 I=1,IGB,IGA                                                    LTEND.64    
   60 Z(I)=Z(I)+EZ                                                         LTEND.65    
C                                                                          LTEND.66    
      RETURN                                                               LTEND.67    
      END                                                                  LTEND.68    
C     ****************************************************************     LTEND.69    
*DECK NSPECT                                                               NSPECT.1     
      SUBROUTINE NSPECT                                                    KSPEC2.3     
C                                                                          KSPEC2.4     
C     Calculate KE spectra over total wavenumber 'n' and over zonal        KSPEC2.5     
C     wavenumber 'm' at current analysis time.                             KSPEC2.6     
C        RKE(,,1) contains n-spectrum                                      KSPEC2.7     
C        RKE(,,2) contains m-spectrum                                      KSPEC2.8     
C     Print spectra and total eddy-KE on channel NPC4.                     KSPEC2.9     
C     If LSPPLT=.T., additionally write spectra formatted:                 KSPEC2.10    
C        Channel NCPLOT(3) : m-spectrum.                                   KSPEC2.11    
C        Channel NCPLOT(2) : n-spectrum.                                   KSPEC2.12    
C     No time series are written in this version.                          KSPEC2.13    
C     Mike Blackburn, 01.12.89.  Original version in BGLFUX2.              KSPEC2.14    
C     Mike Blackburn, 12.05.95.  Formatted output to NCPLOT() units.       KSPEC2.15    
C     Mike Blackburn, 19.05.95.  Compute time averages.                    KSPEC2.16    
C                                                                          KSPEC2.17    
*CALL PARAM1                                                               KSPEC2.18    
*CALL PARAM2                                                               KSPEC2.19    
*CALL BATS                                                                 KSPEC2.20    
*CALL BLANK                                                                KSPEC2.21    
*CALL COMIOC                                                               KSPEC2.22    
*CALL OUTCON                                                               KSPEC2.23    
*CALL SPEC                                                                 KSPEC2.24    
*CALL SPECTR                                                               KSPEC2.25    
      REAL TKEDDY(2)                                                       KSPEC2.26    
      LOGICAL LCOPY6                                                       KSPEC2.27    
      CHARACTER ILAB(2)*20                                                 KSPEC2.28    
      SAVE ILAB                                                            KSPEC2.29    
C                                                                          KSPEC2.30    
      DATA ILAB/'TOTAL WAVENUMBER (N)'                                     KSPEC2.31    
     *         ,'ZONAL WAVENUMBER (M)'/                                    KSPEC2.32    
C                                                                          KSPEC2.33    
 6000 FORMAT(' PROCESSING KE M & N SPECTRA  AT DAY',F10.2,' KOUNT=',I10)   KSPEC2.34    
 6001 FORMAT(' PROCESSING TIME AVERAGED KINETIC ENERGY M & N SPECTRA')     KSPEC2.35    
 6010 FORMAT(/' TOTAL EDDY KE PER UNIT AREA (TKE) (JOULES/M2)',1PE12.5)    KSPEC2.36    
 6011 FORMAT(/'# KINETIC ENERGY SPECTRUM AS FUNCTION OF ',A)               KSPEC2.37    
 6012 FORMAT('# RUN NUMBER ',F10.3,'    DAY = ',F10.2,'  KOUNT = ',I10)    KSPEC2.38    
 6013 FORMAT('# RUN NUMBER ',F10.3,'    DAY ',F10.2,' TO ',F10.2)          KSPEC2.39    
 6020 FORMAT(1X,I6,I4/10(1PE12.5))                                         KSPEC2.40    
 6030 FORMAT('# VERTICALLY INTEGRATED SPECTRUM (WAVENUMBERS FIRST):')      KSPEC2.41    
 6031 FORMAT(20I4)                                                         KSPEC2.42    
 6032 FORMAT(10(1PE12.5))                                                  KSPEC2.43    
C                                                                          KSPEC2.44    
C     Preset time averages at the first analysis time.                     KSPEC2.45    
C                                                                          KSPEC2.46    
      IF (LTAV.AND.KOUNT.EQ.KSTART) THEN                                   KSPEC2.47    
         DO 10 II=1,2                                                      KSPEC2.48    
         DO 10 L=1,NLP                                                     KSPEC2.49    
         DO 10 N=2,NFPP                                                    KSPEC2.50    
         RKET(N,L,II)=0.                                                   KSPEC2.51    
   10    CONTINUE                                                          KSPEC2.52    
      ENDIF                                                                KSPEC2.53    
C                                                                          KSPEC2.54    
C     ------------------------------------------------------------------   KSPEC2.55    
C     Process the KE spectra for the current analysis time.                KSPEC2.56    
C                                                                          KSPEC2.57    
      IF (KOUNT.GE.0) THEN                                                 KSPEC2.58    
C                                                                          KSPEC2.59    
      IF (NPC4.NE.6) THEN                                                  KSPEC2.60    
         WRITE(NPC4,'(///)')                                               KSPEC2.61    
         WRITE(NPC4,6000) DAY,KOUNT                                        KSPEC2.62    
      ENDIF                                                                KSPEC2.63    
      WRITE(6,6000) DAY,KOUNT                                              KSPEC2.64    
C                                                                          KSPEC2.65    
C     Preset instantaneous fields.                                         KSPEC2.66    
C                                                                          KSPEC2.67    
      DO 20 II=1,2                                                         KSPEC2.68    
      DO 20 L=1,NLP                                                        KSPEC2.69    
      DO 20 N=2,NFPP                                                       KSPEC2.70    
      RKE(N,L,II)=0.                                                       KSPEC2.71    
   20 CONTINUE                                                             KSPEC2.72    
C                                                                          KSPEC2.73    
      MP=0                                                                 KSPEC2.74    
      DO 30 M=1,MFPP,MOCT                                                  KSPEC2.75    
      MP=MP+1                                                              KSPEC2.76    
      DO 30 JP=M,NFPP                                                      KSPEC2.77    
      ZL(JP,MP)=(0.,0.)                                                    KSPEC2.78    
      DL(JP,MP)=(0.,0.)                                                    KSPEC2.79    
   30 CONTINUE                                                             KSPEC2.80    
C                                                                          KSPEC2.81    
C     Compute KE spectra at each level, using spectral Z,D.                KSPEC2.82    
C                                                                          KSPEC2.83    
      IOLD=0                                                               KSPEC2.84    
      DO 100 L=1,NL                                                        KSPEC2.85    
C                                                                          KSPEC2.86    
C     First extract/copy spectral coefficients.                            KSPEC2.87    
C                                                                          KSPEC2.88    
      DO 40 IHEM=1,NHEM                                                    KSPEC2.89    
      MP=0                                                                 KSPEC2.90    
      DO 40 M=1,MFP,MOCT                                                   KSPEC2.91    
      MP=MP+1                                                              KSPEC2.92    
      DO 40 JP=M,NFP,MH                                                    KSPEC2.93    
      IOLD=IOLD+1                                                          KSPEC2.94    
      DL(JP+IHEM-1,MP)=D(IOLD)                                             KSPEC2.95    
      ZL(JP+2-IHEM,MP)=Z(IOLD)                                             KSPEC2.96    
   40 CONTINUE                                                             KSPEC2.97    
C                                                                          KSPEC2.98    
C     k(n) spectrum, summing over 'm' for each 'n'.                        KSPEC2.99    
C                                                                          KSPEC2.100   
      DO 60 N=2,NFPP                                                       KSPEC2.101   
      IF (MOCTP.GT.N) GOTO 60                                              KSPEC2.102   
      MP=1                                                                 KSPEC2.103   
      MMAX=MIN0(N,MFP)                                                     KSPEC2.104   
      DO 50 M=MOCTP,MMAX,MOCT                                              KSPEC2.105   
      MP=MP+1                                                              KSPEC2.106   
      RKE(N,L,1)=RKE(N,L,1)+(ZL(N,MP)*CONJG(ZL(N,MP))                      KSPEC2.107   
     *                      +DL(N,MP)*CONJG(DL(N,MP)))/SQ(N)               KSPEC2.108   
   50 CONTINUE                                                             KSPEC2.109   
   60 CONTINUE                                                             KSPEC2.110   
C                                                                          KSPEC2.111   
C     k(m) spectrum, summing over 'n' for each 'm'                         KSPEC2.112   
C                                                                          KSPEC2.113   
      MN=1                                                                 KSPEC2.114   
      DO 70 MP=MOCTP,MFP,MOCT                                              KSPEC2.115   
      MN=MN+1                                                              KSPEC2.116   
      DO 70 N=MP,NFPP                                                      KSPEC2.117   
      RKE(MN,L,2)=RKE(MN,L,2)+(ZL(N,MN)*CONJG(ZL(N,MN))                    KSPEC2.118   
     *                        +DL(N,MN)*CONJG(DL(N,MN)))/SQ(N)             KSPEC2.119   
   70 CONTINUE                                                             KSPEC2.120   
C                                                                          KSPEC2.121   
  100 CONTINUE                                                             KSPEC2.122   
C                                                                          KSPEC2.123   
C     Loop over spectra, 'n' spectrum preceding 'm'.                       KSPEC2.124   
C                                                                          KSPEC2.125   
      DO 150 II=1,2                                                        KSPEC2.126   
C                                                                          KSPEC2.127   
C     Set wavenumber count (+1, since subscript begins at 2).              KSPEC2.128   
C                                                                          KSPEC2.129   
      IF (II.EQ.1) THEN                                                    KSPEC2.130   
         MMAX=NFPP                                                         KSPEC2.131   
         IF (MOD(NN,2).EQ.0.AND.MOD(MOCT,2).EQ.0) MMAX=NFP                 KSPEC2.132   
      ELSE                                                                 KSPEC2.133   
         MMAX=NWW                                                          KSPEC2.134   
      ENDIF                                                                KSPEC2.135   
C                                                                          KSPEC2.136   
C     Dimensionalise spectrum at each level.                               KSPEC2.137   
C     Integrate over levels for total in the (,NLP,) element,              KSPEC2.138   
C     making the approximation of constant surface pressure, P0.           KSPEC2.139   
C                                                                          KSPEC2.140   
      DO 110 L=1,NL                                                        KSPEC2.141   
      DO 110 N=2,MMAX                                                      KSPEC2.142   
      RKE(N,L,II)=RKE(N,L,II)*RKEFAC                                       KSPEC2.143   
      RKE(N,NLP,II)=RKE(N,NLP,II)+RKE(N,L,II)*DSIGMA(L)                    KSPEC2.144   
  110 CONTINUE                                                             KSPEC2.145   
C                                                                          KSPEC2.146   
  150 CONTINUE                                                             KSPEC2.147   
C                                                                          KSPEC2.148   
C     Accumulate time averages if required.                                KSPEC2.149   
C                                                                          KSPEC2.150   
      IF (LTAV) THEN                                                       KSPEC2.151   
         FD=FTAV                                                           KSPEC2.152   
         IF (KOUNT.EQ.KSTART.OR.KOUNT.EQ.KEND) FD=.5*FD                    KSPEC2.153   
         DO 160 II=1,2                                                     KSPEC2.154   
         DO 160 L=1,NLP                                                    KSPEC2.155   
         DO 160 N=2,NFPP                                                   KSPEC2.156   
         RKET(N,L,II)=RKET(N,L,II)+RKE(N,L,II)*FD                          KSPEC2.157   
  160    CONTINUE                                                          KSPEC2.158   
      ENDIF                                                                KSPEC2.159   
C                                                                          KSPEC2.160   
      ENDIF                                                                KSPEC2.161   
C                                                                          KSPEC2.162   
C     ------------------------------------------------------------------   KSPEC2.163   
C     Process time averaged KE spectra if required (multiple analyses).    KSPEC2.164   
C                                                                          KSPEC2.165   
      IF (KOUNT.LT.0.AND.LTAV) THEN                                        KSPEC2.166   
C                                                                          KSPEC2.167   
      IF (NPC4.NE.6) THEN                                                  KSPEC2.168   
         WRITE(NPC4,'(///)')                                               KSPEC2.169   
         WRITE(NPC4,6001)                                                  KSPEC2.170   
      ENDIF                                                                KSPEC2.171   
      WRITE(6,6001)                                                        KSPEC2.172   
C                                                                          KSPEC2.173   
C     Copy the time-average array to the instantaneous.                    KSPEC2.174   
C                                                                          KSPEC2.175   
      DO 210 II=1,2                                                        KSPEC2.176   
      DO 210 L=1,NLP                                                       KSPEC2.177   
      DO 210 N=2,NFPP                                                      KSPEC2.178   
      RKE(N,L,II)=RKET(N,L,II)                                             KSPEC2.179   
  210 CONTINUE                                                             KSPEC2.180   
C                                                                          KSPEC2.181   
      ENDIF                                                                KSPEC2.182   
C                                                                          KSPEC2.183   
      IF (KOUNT.LT.0.AND..NOT.LTAV) RETURN                                 KSPEC2.184   
C                                                                          KSPEC2.185   
C     ------------------------------------------------------------------   KSPEC2.186   
C     Write the spectra as required.                                       KSPEC2.187   
C                                                                          KSPEC2.188   
      IF (KOUNT.LT.0.OR.KEND.EQ.KSTART) THEN                               KSPEC2.189   
         LCOPY6=.TRUE.                                                     KSPEC2.190   
      ELSE                                                                 KSPEC2.191   
         LCOPY6=.FALSE.                                                    KSPEC2.192   
      ENDIF                                                                KSPEC2.193   
      IF (NPC4.EQ.6) LCOPY6=.FALSE.                                        KSPEC2.194   
C                                                                          KSPEC2.195   
      DO 350 II=1,2                                                        KSPEC2.196   
C                                                                          KSPEC2.197   
      IF (II.EQ.1) THEN                                                    KSPEC2.198   
         MMAX=NFPP                                                         KSPEC2.199   
         IF (MOD(NN,2).EQ.0.AND.MOD(MOCT,2).EQ.0) MMAX=NFP                 KSPEC2.200   
         MIN=MOCT                                                          KSPEC2.201   
         MAX=MMAX-1                                                        KSPEC2.202   
         INC=1                                                             KSPEC2.203   
         MINE=MIN+1                                                        KSPEC2.204   
         MAXE=MAX+1                                                        KSPEC2.205   
         INCE=INC                                                          KSPEC2.206   
      ELSE                                                                 KSPEC2.207   
         MMAX=NWW                                                          KSPEC2.208   
         MIN=MOCT                                                          KSPEC2.209   
         MAX=MF                                                            KSPEC2.210   
         INC=MOCT                                                          KSPEC2.211   
         MINE=2                                                            KSPEC2.212   
         MAXE=MMAX                                                         KSPEC2.213   
         INCE=1                                                            KSPEC2.214   
      ENDIF                                                                KSPEC2.215   
C                                                                          KSPEC2.216   
C     Sum over all non-zero wavenumbers to obtain total eddy KE.           KSPEC2.217   
C                                                                          KSPEC2.218   
      TKEDDY(II)=SSUM(MMAX-1,RKE(2,NLP,II),1)                              KSPEC2.219   
C                                                                          KSPEC2.220   
C     Print spectra at all levels.                                         KSPEC2.221   
C                                                                          KSPEC2.222   
      WRITE(NPC4,6010) TKEDDY(II)                                          KSPEC2.223   
      WRITE(NPC4,6011) ILAB(II)                                            KSPEC2.224   
      DO 310 N=2,MMAX                                                      KSPEC2.225   
      NM=(N-1)*INC                                                         KSPEC2.226   
      WRITE(NPC4,6020) KOUNT,NM,(RKE(N,L,II),L=1,NLP)                      KSPEC2.227   
  310 CONTINUE                                                             KSPEC2.228   
      IF (LCOPY6) THEN                                                     KSPEC2.229   
         WRITE(6,6010) TKEDDY(II)                                          KSPEC2.230   
         WRITE(6,6011) ILAB(II)                                            KSPEC2.231   
         DO 320 N=2,MMAX                                                   KSPEC2.232   
         NM=(N-1)*INC                                                      KSPEC2.233   
         WRITE(6,6020) KOUNT,NM,(RKE(N,L,II),L=1,NLP)                      KSPEC2.234   
  320    CONTINUE                                                          KSPEC2.235   
      ENDIF                                                                KSPEC2.236   
C                                                                          KSPEC2.237   
C     Print vertically integrated spectra.                                 KSPEC2.238   
C                                                                          KSPEC2.239   
      WRITE(NPC4,6030)                                                     KSPEC2.240   
      WRITE(NPC4,6031) (I,I=MIN,MAX,INC)                                   KSPEC2.241   
      WRITE(NPC4,6032) (RKE(I,NLP,II),I=MINE,MAXE,INCE)                    KSPEC2.242   
      IF (LCOPY6) THEN                                                     KSPEC2.243   
         WRITE(6,6030)                                                     KSPEC2.244   
         WRITE(6,6031) (I,I=MIN,MAX,INC)                                   KSPEC2.245   
         WRITE(6,6032) (RKE(I,NLP,II),I=MINE,MAXE,INCE)                    KSPEC2.246   
      ENDIF                                                                KSPEC2.247   
C                                                                          KSPEC2.248   
C     Write vertically integrated spectra to plot file.                    KSPEC2.249   
C                                                                          KSPEC2.250   
      IF (LSPPLT) THEN                                                     KSPEC2.251   
         WRITE(NCPLOT(II+1),6011) ILAB(II)                                 KSPEC2.252   
         IF (KOUNT.GE.0) THEN                                              KSPEC2.253   
            WRITE(NCPLOT(II+1),6012) RNTAPE,DAY,KOUNT                      KSPEC2.254   
         ELSE                                                              KSPEC2.255   
            WRITE(NCPLOT(II+1),6013) RNTAPE                                KSPEC2.256   
     :                              ,REAL(KSTART)/TSPD,REAL(KEND)/TSPD     ANSI2.304   
         ENDIF                                                             KSPEC2.258   
         WRITE(NCPLOT(II+1),6030)                                          KSPEC2.259   
         J=MINE                                                            KSPEC2.260   
         DO 330 I=MIN,MAX,INC                                              KSPEC2.261   
         WRITE(NCPLOT(II+1),'(I5,1PE12.5)') I,RKE(J,NLP,II)                KSPEC2.262   
         J=J+INCE                                                          KSPEC2.263   
  330    CONTINUE                                                          KSPEC2.264   
      ENDIF                                                                KSPEC2.265   
C                                                                          KSPEC2.266   
  350 CONTINUE                                                             KSPEC2.267   
C                                                                          KSPEC2.268   
      RETURN                                                               KSPEC2.269   
      END                                                                  KSPEC2.270   
C     ******************************************************************   KSPEC2.271   
*DECK OPCOEF                                                               OPCOEF.1     
      SUBROUTINE OPCOEF                                                    OPCOEF.2     
C                                                                          OPCOEF.3     
C     Print spectral coefficients for model level fields.                  OPCOEF.4     
C                                                                          OPCOEF.5     
*CALL PARAM1                                                               OPCOEF.6     
*CALL PARAM2                                                               OPCOEF.7     
      PARAMETER(NOUT=6)                                                    OPCOEF.8     
C                                                                          OPCOEF.9     
*CALL BATS                                                                 OPCOEF.10    
*CALL BLANK                                                                OPCOEF.11    
*CALL OUTCON                                                               OPCOEF.12    
*CALL SPECTR                                                               OPCOEF.13    
      CHARACTER NAME(NOUT)*50                                              OPCOEF.14    
      SAVE NAME                                                            OPCOEF.15    
C                                                                          OPCOEF.16    
      DATA (NAME(N),N=1,NOUT)/                                             OPCOEF.17    
     1 'RELATIVE VORTICITY   ON SIGMA=           NON-DIM  '                OPCOEF.18    
     2,'DIVERGENCE           ON SIGMA=           NON-DIM  '                OPCOEF.19    
     3,'PERT. TEMPERATURE    ON SIGMA=           NON-DIM  '                OPCOEF.20    
     4,'SPECIFIC HUMIDITY    ON SIGMA=           NON-DIM  '                OPCOEF.21    
     5,'DIABATIC HEATING     ON SIGMA=           NON-DIM  '                OPCOEF.22    
     6,'LOG(SURFACE PRESSURE)                    NON-DIM  '                OPCOEF.23    
     :/                                                                    OPCOEF.24    
C                                                                          OPCOEF.25    
 6000 FORMAT(' PROCESSING SPECTRAL COEFFS   AT DAY',F10.2,' KOUNT=',I10)   OPCOEF.26    
 6010 FORMAT(/' DAY',F10.2,'  NUMBER OF TIME STEPS COMPLETED =',I10)       OPCOEF.27    
 6020 FORMAT(/' SPECTRAL COEFFICIENTS'/4('   COEFF  AMPLITUDE   PHASE'))   OPCOEF.28    
 6030 FORMAT(1X,A)                                                         OPCOEF.29    
C                                                                          OPCOEF.30    
      IF (NPC1.NE.6) THEN                                                  OPCOEF.31    
         IF (LOUTP) WRITE(NPC1,'(///)')                                    OPCOEF.32    
         WRITE(NPC1,6000) DAY,KOUNT                                        OPCOEF.33    
      ENDIF                                                                OPCOEF.34    
      WRITE(6,6000) DAY,KOUNT                                              OPCOEF.35    
C                                                                          OPCOEF.36    
      DO 1 I=1,IGB,IGA                                                     OPCOEF.37    
    1 Z(I)=Z(I)-EZ                                                         OPCOEF.38    
      WRITE(NPC1,6020)                                                     OPCOEF.39    
      DO 10 L=1,NL                                                         OPCOEF.40    
      IF (.NOT.LSPO(L)) GOTO 10                                            OPCOEF.41    
      WRITE(NAME(1)(31:36),'(F6.4)') SIGMA(L)                              OPCOEF.42    
      WRITE(NPC1,6030) NAME(1)                                             OPCOEF.43    
      CALL WRSPS(Z(1+(L-1)*IGA),1)                                         OPCOEF.44    
   10 CONTINUE                                                             OPCOEF.45    
      DO 11 I=1,IGB,IGA                                                    OPCOEF.46    
   11 Z(I)=Z(I)+EZ                                                         OPCOEF.47    
C                                                                          OPCOEF.48    
      WRITE(NPC1,6010) DAY,KOUNT                                           OPCOEF.49    
      WRITE(NPC1,6020)                                                     OPCOEF.50    
      DO 20 L=1,NL                                                         OPCOEF.51    
      IF (.NOT.LSPO(L)) GOTO 20                                            OPCOEF.52    
      WRITE(NAME(2)(31:36),'(F6.4)') SIGMA(L)                              OPCOEF.53    
      WRITE(NPC1,6030) NAME(2)                                             OPCOEF.54    
      CALL WRSPS(D(1+(L-1)*IGA),2)                                         OPCOEF.55    
   20 CONTINUE                                                             OPCOEF.56    
C                                                                          OPCOEF.57    
      WRITE(NPC1,6010) DAY,KOUNT                                           OPCOEF.58    
      WRITE(NPC1,6020)                                                     OPCOEF.59    
      DO 30 L=1,NL                                                         OPCOEF.60    
      IF (.NOT.LSPO(L)) GOTO 30                                            OPCOEF.61    
      WRITE(NAME(3)(31:36),'(F6.4)') SIGMA(L)                              OPCOEF.62    
      WRITE(NPC1,6030) NAME(3)                                             OPCOEF.63    
      CALL WRSPS(T(1+(L-1)*IGA),2)                                         OPCOEF.64    
   30 CONTINUE                                                             OPCOEF.65    
C                                                                          OPCOEF.66    
      IF (.NOT.LDRY) THEN                                                  BUGS5.9     
         WRITE(NPC1,6010) DAY,KOUNT                                        BUGS5.10    
         WRITE(NPC1,6020)                                                  BUGS5.11    
         DO 40 L=1,NL                                                      BUGS5.12    
         IF (.NOT.LSPO(L)) GOTO 40                                         BUGS5.13    
         WRITE(NAME(4)(31:36),'(F6.4)') SIGMA(L)                           BUGS5.14    
         WRITE(NPC1,6030) NAME(4)                                          BUGS5.15    
         CALL WRSPS(Q(1+(L-1)*IGA),2)                                      BUGS5.16    
   40    CONTINUE                                                          BUGS5.17    
      ENDIF                                                                BUGS5.18    
C                                                                          OPCOEF.75    
      WRITE(NPC1,6010) DAY,KOUNT                                           OPCOEF.76    
      WRITE(NPC1,6020)                                                     OPCOEF.77    
      DO 50 L=1,NL                                                         OPCOEF.78    
      IF (.NOT.LSPO(L)) GOTO 50                                            OPCOEF.79    
      WRITE(NAME(5)(31:36),'(F6.4)') SIGMA(L)                              OPCOEF.80    
      WRITE(NPC1,6030) NAME(5)                                             OPCOEF.81    
      CALL WRSPS(H(1+(L-1)*IGA),2)                                         OPCOEF.82    
   50 CONTINUE                                                             OPCOEF.83    
C                                                                          OPCOEF.84    
      WRITE(NPC1,6010) DAY,KOUNT                                           OPCOEF.85    
      WRITE(NPC1,6020)                                                     OPCOEF.86    
      WRITE(NPC1,6030) NAME(6)                                             OPCOEF.87    
      CALL WRSPS(SP(1),2)                                                  OPCOEF.88    
C                                                                          OPCOEF.89    
      RETURN                                                               OPCOEF.90    
      END                                                                  OPCOEF.91    
C     ****************************************************************     OPCOEF.92    
*DECK WRSPS                                                                WRSPS.1     
      SUBROUTINE WRSPS(A,IA)                                               WRSPS.2     
C                                                                          WRSPS.3     
C     Print spectral coefficients for single field at a single level.      WRSPS.4     
C     Entry WRSPI is called from INITAL to write invariant data to         WRSPS.5     
C     character array COEFF and set up pointer and scaling arrays,         WRSPS.6     
C     to optimise the formatted output.                                    WRSPS.7     
C                                                                          WRSPS.8     
*CALL PARAM1                                                               WRSPS.9     
*CALL PARAM2                                                               WRSPS.10    
      PARAMETER(RAD=180./PI)                                               WRSPS.11    
C                                                                          WRSPS.12    
*CALL BLANK                                                                WRSPS.13    
*CALL OUTCON                                                               WRSPS.14    
      COMPLEX A(NWJ2),POLAR,Z                                              WRSPS.15    
      CHARACTER COEFF(NWJ2,2)*8                                            WRSPS.16    
      REAL FP(IGA)                                                         WRSPS.17    
      INTEGER IP(IGA)                                                      WRSPS.18    
      SAVE COEFF,FP,IP                                                     WRSPS.19    
C                                                                          WRSPS.20    
      DATA COEFF/MJP*' (  ,  )'/                                           WRSPS.21    
C                                                                          WRSPS.22    
      POLAR(Z)=CMPLX(ABS(Z),ATAN2(AIMAG(Z),REAL(Z)+1.0E-20)*RAD)           SUNMOD.90    
C                                                                          WRSPS.24    
C     ----------------------------------------------------------------     WRSPS.25    
C     Write cofficients using preset arrays and pointers.                  WRSPS.26    
C                                                                          WRSPS.27    
      IF (NHEM.EQ.1) THEN                                                  WRSPS.28    
         WRITE(NPC1,6000)(COEFF(I,IA),POLAR(A(IP(I))*FP(I)),I=1,INSPC)     WRSPS.29    
      ELSE                                                                 WRSPS.30    
         WRITE(NPC1,6000)(COEFF(I,2),POLAR(A(IP(I)+(2-IA)*NWJ2)*FP(I))     WRSPS.31    
     :   ,COEFF(I,1),POLAR(A(IP(I)+(IA-1)*NWJ2)*FP(I)),I=1,INSPC)          WRSPS.32    
      ENDIF                                                                WRSPS.33    
 6000 FORMAT(4(A8,E11.4,F8.2))                                             WRSPS.34    
C                                                                          WRSPS.35    
      RETURN                                                               WRSPS.36    
C                                                                          WRSPS.37    
C     ----------------------------------------------------------------     WRSPS.38    
      ENTRY WRSPI(A,IA)                                                    WRSPS.39    
C                                                                          WRSPS.40    
C     Initialise pointers for output resolution in full resolution         WRSPS.41    
C     spectral arrays.  Initialise character array with invariant data.    WRSPS.42    
C                                                                          WRSPS.43    
      I=0                                                                  WRSPS.44    
      IG=0                                                                 WRSPS.45    
      DO 20 MP=1,MFP,MOCT                                                  WRSPS.46    
      IF (MP.GT.NCOEFF) GOTO 30                                            WRSPS.47    
      IBEG=IG                                                              WRSPS.48    
      DO 10 JP=MP,NCOEFF,MH                                                WRSPS.49    
      I=I+1                                                                WRSPS.50    
      IG=IG+1                                                              WRSPS.51    
      IP(I)=IG                                                             WRSPS.52    
      IF (MP.EQ.1) THEN                                                    SUNMOD.83    
        FP(I)=1.                                                           SUNMOD.84    
       ELSE                                                                SUNMOD.85    
        FP(I)=2.                                                           SUNMOD.86    
       ENDIF                                                               SUNMOD.87    
      WRITE(COEFF(I,1)(3:4),'(I2)')MP-1                                    WRSPS.54    
      WRITE(COEFF(I,2)(3:4),'(I2)')MP-1                                    WRSPS.55    
      WRITE(COEFF(I,1)(6:7),'(I2)')JP                                      WRSPS.56    
      WRITE(COEFF(I,2)(6:7),'(I2)')JP-1                                    WRSPS.57    
   10 CONTINUE                                                             WRSPS.58    
      IG=IBEG+(NFP-MP+2)/MH                                                WRSPS.59    
   20 CONTINUE                                                             WRSPS.60    
   30 CONTINUE                                                             WRSPS.61    
C                                                                          WRSPS.62    
      RETURN                                                               WRSPS.63    
      END                                                                  WRSPS.64    
C     ****************************************************************     WRSPS.65    
*DECK LTI                                                                  LTI.1     
      SUBROUTINE LTI                                                       LTI.2     
C                                                                          LTI.3     
C     Inverse Legendre transform, from spectral to Fourier space.          LTI.4     
C     HEXP transforms fields having the same symmetry and type of          LTI.5     
C     polynomial (ALP, DALP, RLP, RDLP etc).                               LTI.6     
C                                                                          LTI.7     
*CALL PARAM1                                                               LTI.8     
*CALL PARAM2                                                               LTI.9     
*CALL BLANK                                                                LTI.10    
*CALL GRIDP                                                                LTI.11    
*CALL POLYNO                                                               LTI.12    
*CALL SPECTR                                                               LTI.13    
      COMPLEX CUG(IGK),CVG(IGK),CSFG(IGK)                                  LTI.14    
     :,CTPG(IGL*NLP),CTPXG(IGL*NLP)                                        LTI.15    
      EQUIVALENCE (CUG(1),UG(1)),(CVG(1),VG(1)),(CSFG(1),SFG(1))           LTI.16    
     :,(CTPG(1),TG(1)),(CTPXG(1),TXG(1))                                   LTI.17    
C                                                                          LTI.18    
C     Absolute vorticity. Remove planetary vorticity for subsequent        LTI.19    
C     transforms requiring relative vorticity.                             LTI.20    
C                                                                          LTI.21    
      CALL HEXP(Z,ZG,NL,1)                                                 LTI.22    
      DO 10 I=1,IGB,IGA                                                    LTI.23    
   10 Z(I)=Z(I)-EZ                                                         LTI.24    
C                                                                          LTI.25    
C     Wind components.  Calls to HEXP give following Fourier fields:       LTI.26    
C        UG   :   -U(rot).                                                 LTI.27    
C        VG   :   V(div).                                                  LTI.28    
C        SFG  :   streamfunction.                                          LTI.29    
C        TG   :   velocty-potential.  (Temporary - overwritten below).     LTI.30    
C     Then sum to give total winds.  CMPA takes x-derivative.              LTI.31    
C                                                                          LTI.32    
      CALL HEXP(Z,UG ,NL,7)                                                LTI.33    
      CALL HEXP(Z,SFG,NL,5)                                                LTI.34    
      CALL HEXP(D,TG ,NL,6)                                                LTI.35    
      CALL HEXP(D,VG ,NL,8)                                                LTI.36    
      II=0                                                                 LTI.37    
      DO 20 L=1,NL                                                         LTI.38    
      DO 20 I=1,IGL                                                        LTI.39    
      II=II+1                                                              LTI.40    
      CUG(II)=CTPG(II)*CMPA(I)-CUG(II)                                     LTI.41    
      CVG(II)=CSFG(II)*CMPA(I)+CVG(II)                                     LTI.42    
   20 CONTINUE                                                             LTI.43    
C                                                                          LTI.44    
C     Symmetric spectral fields and their derivatives (D,Q,H,T,SP).        LTI.45    
C                                                                          LTI.46    
      CALL HEXP(D,DG,4*NL+1,2)                                             LTI.47    
      CALL HEXP(T,TYG,NLP,4)                                               LTI.48    
      II=0                                                                 LTI.49    
      DO 30 L=1,NLP                                                        LTI.50    
      DO 30 I=1,IGL                                                        LTI.51    
      II=II+1                                                              LTI.52    
   30 CTPXG(II)=CTPG(II)*CMPA(I)                                           LTI.53    
C                                                                          LTI.54    
      DO 40 I=1,IGB,IGA                                                    LTI.55    
   40 Z(I)=Z(I)+EZ                                                         LTI.56    
C                                                                          LTI.57    
      RETURN                                                               LTI.58    
      END                                                                  LTI.59    
C     ****************************************************************     LTI.60    
*DECK HEXP                                                                 HEXP.1     
      SUBROUTINE HEXP(SV,GV,NLS,ITYPE)                                     HEXP.2     
C                                                                          HEXP.3     
C     Performs indirect Legendre transform for a (set of) field(s)         HEXP.4     
C     having a total of NLS levels, from spectral to Fourier space.        HEXP.5     
C     The type of function and thence of transform is chosen by ITYPE      HEXP.6     
C     with the following currently defined:                                HEXP.7     
C        ITYPE=1,2   :   ALP     :   normal transform.                     HEXP.8     
C        ITYPE=3,4   :   DALP    :   y-derivative.                         HEXP.9     
C        ITYPE=5,6   :   RLP     :   del(-2).                              HEXP.10    
C        ITYPE=7,8   :   RDLP    :   y-derivative of del(-2).              HEXP.11    
C     An even/odd value of ITYPE denotes a spectral field of even/odd      HEXP.12    
C     symmetry.                                                            HEXP.13    
C                                                                          HEXP.14    
*CALL PARAM1                                                               HEXP.15    
*CALL PARAM2                                                               HEXP.16    
*CALL BLANK                                                                HEXP.17    
*CALL LEGAU                                                                HEXP.18    
*CALL POLYNO                                                               HEXP.19    
      COMPLEX SV(IGA*NLS),GV(IGL*NLS),TEMP                                 HEXP.20    
      REAL ALPN(MJP,JGL,4)                                                 HEXP.21    
      EQUIVALENCE (ALPN(1,1,1),ALP(1,1))                                   HEXP.22    
C                                                                          HEXP.23    
 6900 FORMAT(/' ***ABORT : HEXP CALLED WITH TYPE =',I5)                    HEXP.24    
C                                                                          HEXP.25    
C                                                                          HEXP.26    
C     Preset Fourier array to zero.                                        HEXP.27    
C                                                                          HEXP.28    
      DO 10 I=1,IGL*NLS                                                    HEXP.29    
   10 GV(I)=0.                                                             HEXP.30    
C                                                                          HEXP.31    
C     Use ITYPE to define transform type and symmetry labels.              HEXP.32    
C     ISPAR is symmetry of spectral field    = 0 for D,T,SP etc.           HEXP.33    
C                                            = 1 for Z.                    HEXP.34    
C     IGPAR is symmetry of Fourier field: same as ISPAR unless transform   HEXP.35    
C                                         involves a d/dy.                 HEXP.36    
C                                                                          HEXP.37    
      IF (ITYPE.LE.0.OR.ITYPE.GE.9) THEN                                   HEXP.38    
         WRITE(6,6900) ITYPE                                               HEXP.39    
         CALL ABORT                                                        HEXP.40    
      ENDIF                                                                HEXP.41    
      IALP=(ITYPE+1)/2                                                     HEXP.42    
      ISPAR=MOD(ITYPE,2)                                                   HEXP.43    
      IGPAR=ISPAR                                                          HEXP.44    
      IF (IALP.EQ.2.OR.IALP.EQ.4) IGPAR=1-ISPAR                            HEXP.45    
C                                                                          HEXP.46    
C     Calculate POLY array in vector loop before main transform.           HEXP.47    
C                                                                          HEXP.48    
      DO 30 IHEM=1,NHEM                                                    HEXP.49    
      INC=(IHEM-1)*(1-ISPAR)+(2-IHEM)*ISPAR                                HEXP.50    
      IA=INC-1                                                             HEXP.51    
      DO 20 IP=1,NWJ2                                                      HEXP.52    
      IA=IA+2                                                              HEXP.53    
   20 POLY(IP,IHEM)=ALPN(IA,JL,IALP)                                       HEXP.54    
   30 CONTINUE                                                             HEXP.55    
C                                                                          HEXP.56    
C     Perform inverse Legendre transform from spectral space to form       HEXP.57    
C     the even and odd contributions to the Fourier transforms.            HEXP.58    
C     Separate code for NHEM=1,2 to increase efficiency.                   HEXP.59    
C                                                                          HEXP.60    
      IF (NHEM.EQ.1) THEN                                                  HEXP.61    
         IM=-IDL                                                           HEXP.62    
         IP=-NWJ2                                                          HEXP.63    
         DO 40 MP=1,MFP,MOCT                                               HEXP.64    
         IM=IM+1                                                           HEXP.65    
         DO 40 IN=MP,NFP,MH                                                HEXP.66    
         IP=IP+1                                                           HEXP.67    
         DO 40 IV=1,NLS                                                    HEXP.68    
   40    GV(IM+IV*IDL)=GV(IM+IV*IDL) + POLY(IP+NWJ2,1)*SV(IP+IV*NWJ2)      HEXP.69    
      ELSE                                                                 HEXP.70    
         IM=-IDL                                                           HEXP.71    
         IP=-NWJ2                                                          HEXP.72    
         DO 50 MP=1,MFP,MOCT                                               HEXP.73    
         IM=IM+1                                                           HEXP.74    
         DO 50 IN=MP,NFP,MH                                                HEXP.75    
         IP=IP+1                                                           HEXP.76    
CDIR$    IVDEP                                                             BUGS5.19    
         DO 50 IV=1,NLS*NHEM,2                                             BUGS5.20    
         IW=IV+1                                                           BUGS5.21    
         GV(IM+IV*IDL)=GV(IM+IV*IDL) + POLY(IP+NWJ2,1)*SV(IP+IV*NWJ2)      BUGS5.22    
   50    GV(IM+IW*IDL)=GV(IM+IW*IDL) + POLY(IP+NWJ2,2)*SV(IP+IW*NWJ2)      BUGS5.23    
      ENDIF                                                                HEXP.80    
C                                                                          HEXP.81    
C     For a global run, sum and difference even and odd contributions      HEXP.82    
C     to give the complete Fourier transforms at the northern and          HEXP.83    
C     southern latitude rows.  Separate code for each symmetry:            HEXP.84    
C        IGPAR=0 : even (IA) precedes odd (IB).                            HEXP.85    
C        IGPAR=1 : odd (IA) precedes even (IB).                            LEGUP1.1     
C                                                                          HEXP.87    
      IF (NHEM.EQ.2) THEN                                                  HEXP.88    
         IF (IGPAR.EQ.0) THEN                                              HEXP.89    
            DO 60 M=1,NWW                                                  HEXP.90    
            IA=M-IGL                                                       HEXP.91    
CDIR$ IVDEP                                                                HEXP.92    
            DO 60 IV=1,NLS                                                 HEXP.93    
            IA=IA+IGL                                                      HEXP.94    
            IB=IA+IDL                                                      HEXP.95    
            TEMP=GV(IA)                                                    HEXP.96    
            GV(IA)=TEMP+GV(IB)                                             HEXP.97    
            GV(IB)=TEMP-GV(IB)                                             HEXP.98    
   60       CONTINUE                                                       HEXP.99    
         ELSE                                                              HEXP.100   
            DO 70 M=1,NWW                                                  HEXP.101   
            IA=M-IGL                                                       HEXP.102   
CDIR$ IVDEP                                                                HEXP.103   
            DO 70 IV=1,NLS                                                 HEXP.104   
            IA=IA+IGL                                                      HEXP.105   
            IB=IA+IDL                                                      HEXP.106   
            TEMP=GV(IA)                                                    HEXP.107   
            GV(IA)=GV(IB)+TEMP                                             HEXP.108   
            GV(IB)=GV(IB)-TEMP                                             HEXP.109   
   70       CONTINUE                                                       HEXP.110   
         ENDIF                                                             HEXP.111   
      ENDIF                                                                HEXP.112   
C                                                                          HEXP.113   
      RETURN                                                               HEXP.114   
      END                                                                  HEXP.115   
C     ****************************************************************     HEXP.116   
*DECK HANAL                                                                HANAL.1     
      SUBROUTINE HANAL(GV,GVW,SV,NLS,ITYPE)                                ANSI2.305   
C                                                                          HANAL.3     
C     Performs direct Legendre transform for a (set of) field(s)           HANAL.4     
C     having a total of NLS levels, from Fourier to spectral space.        HANAL.5     
C     The type of function and thence of transform is chosen by ITYPE      HANAL.6     
C     with the following currently defined:                                HANAL.7     
C        ITYPE=1,2   :   ALP     :   normal transform.                     HANAL.8     
C        ITYPE=3,4   :   DALP    :   y-derivative.                         HANAL.9     
C        ITYPE=5,6   :   RLP     :   del(-2).                              LEGUP1.2     
C        ITYPE=7,8   :   RDLP    :   y-derivative of del(-2).              LEGUP1.3     
C     An even/odd value of ITYPE denotes a spectral field of even/odd      HANAL.10    
C     symmetry.                                                            HANAL.11    
C     Input Fourier array GV is no longer corrupted in global runs         LEGUP1.4     
C     (NHEM=2).  A work array GVW is used in that case.                    LEGUP1.5     
C     NOTE: The y-derivative transforms use integration by parts and       LEGUP1.6     
C           are valid only if the input field has zero zonal mean at       LEGUP1.7     
C           both poles.                                                    LEGUP1.8     
C                                                                          HANAL.12    
*CALL PARAM1                                                               HANAL.13    
*CALL PARAM2                                                               HANAL.14    
*CALL BLANK                                                                HANAL.15    
*CALL LEGAU                                                                HANAL.16    
*CALL POLYNO                                                               HANAL.17    
      COMPLEX GV(IGL*NLS),GVW(IGL*NLS),SV(IGA*NLS)                         LEGUP1.9     
      REAL ALPN(MJP,JGL,4)                                                 HANAL.19    
      EQUIVALENCE (ALPN(1,1,1),ALP(1,1))                                   HANAL.20    
C                                                                          HANAL.21    
 6900 FORMAT(/' ***ABORT : HANAL CALLED WITH TYPE =',I5)                   HANAL.22    
C                                                                          HANAL.23    
C     Use ITYPE to define transform type and symmetry labels.              HANAL.24    
C     ISPAR is symmetry of spectral field    = 0 for D,T,SP etc.           HANAL.25    
C                                            = 1 for Z.                    HANAL.26    
C     IGPAR is symmetry of Fourier field: same as ISPAR unless transform   HANAL.27    
C                                         involves a d/dy.                 HANAL.28    
C                                                                          HANAL.29    
      IF (ITYPE.LE.0.OR.ITYPE.GT.8) THEN                                   LEGUP1.10    
         WRITE(6,6900) ITYPE                                               HANAL.31    
         CALL ABORT                                                        HANAL.32    
      ENDIF                                                                HANAL.33    
      IALP=(ITYPE+1)/2                                                     HANAL.34    
      ISPAR=MOD(ITYPE,2)                                                   HANAL.35    
      IGPAR=ISPAR                                                          HANAL.36    
      IF (IALP.EQ.2.OR.IALP.EQ.4) IGPAR=1-ISPAR                            LEGUP1.11    
C                                                                          HANAL.38    
C     For a global run, sum and difference the complete Fourier            HANAL.39    
C     transforms at the northern and southern latitude rows to give        HANAL.40    
C     the even and odd contributions.                                      HANAL.41    
C     Separate code for each symmetry:                                     HANAL.42    
C        IGPAR=0 : even (IA) to precede odd (IB).                          HANAL.43    
C        IGPAR=1 : odd (IA) to precede even (IB).                          LEGUP1.12    
C                                                                          HANAL.45    
      IF (NHEM.EQ.2) THEN                                                  HANAL.46    
         IF (IGPAR.EQ.0) THEN                                              HANAL.47    
            DO 10 M=1,NWW                                                  HANAL.48    
            IA=M-IGL                                                       HANAL.49    
            DO 10 IV=1,NLS                                                 HANAL.51    
            IA=IA+IGL                                                      HANAL.52    
            IB=IA+IDL                                                      HANAL.53    
            GVW(IA)=0.5*(GV(IA)+GV(IB))                                    LEGUP1.13    
            GVW(IB)=0.5*(GV(IA)-GV(IB))                                    LEGUP1.14    
   10       CONTINUE                                                       HANAL.57    
         ELSE                                                              HANAL.58    
            DO 20 M=1,NWW                                                  HANAL.59    
            IA=M-IGL                                                       HANAL.60    
            DO 20 IV=1,NLS                                                 HANAL.62    
            IA=IA+IGL                                                      HANAL.63    
            IB=IA+IDL                                                      HANAL.64    
            GVW(IA)=0.5*(GV(IA)-GV(IB))                                    LEGUP1.15    
            GVW(IB)=0.5*(GV(IA)+GV(IB))                                    LEGUP1.16    
   20       CONTINUE                                                       HANAL.68    
         ENDIF                                                             HANAL.69    
      ENDIF                                                                HANAL.70    
C                                                                          HANAL.71    
C     Set up appropriate Gaussian weight for current latitude.             HANAL.72    
C     Depends on transform type.                                           HANAL.73    
C     Assumes JH in /LEGAU/ contains latitude counter from calling loop.   HANAL.74    
C                                                                          HANAL.75    
      IF (IALP.EQ.1) AWT=AW(JH)*CSSQ(JH)                                   HANAL.76    
      IF (IALP.EQ.2) AWT=-AW(JH)                                           HANAL.77    
      IF (IALP.EQ.3) AWT=AW(JH)*CSSQ(JH)                                   LEGUP1.17    
      IF (IALP.EQ.4) AWT=-AW(JH)                                           LEGUP1.18    
C                                                                          HANAL.78    
C     Calculate POLY array in vector loop before main transform.           HANAL.79    
C                                                                          HANAL.80    
      DO 30 IHEM=1,NHEM                                                    HANAL.81    
      INC=(IHEM-1)*(1-ISPAR)+(2-IHEM)*ISPAR                                HANAL.82    
      IA=INC-1                                                             HANAL.83    
      DO 30 IP=1,NWJ2                                                      HANAL.84    
      IA=IA+2                                                              HANAL.85    
   30 POLY(IP,IHEM)=AWT*ALPN(IA,JL,IALP)                                   HANAL.86    
C                                                                          HANAL.87    
C     Perform direct Legendre transform from the even and odd              HANAL.88    
C     parts of the Fourier transforms to spectral space.                   HANAL.89    
C     Separate code for NHEM=1,2 to increase efficiency.                   HANAL.90    
C                                                                          HANAL.91    
      IF (NHEM.EQ.1) THEN                                                  HANAL.92    
         IM=-IDL                                                           HANAL.93    
         IP=-NWJ2                                                          HANAL.94    
         DO 40 MP=1,MFP,MOCT                                               HANAL.95    
         IM=IM+1                                                           HANAL.96    
         DO 40 IN=MP,NFP,MH                                                HANAL.97    
         IP=IP+1                                                           HANAL.98    
         DO 40 IV=1,NLS                                                    HANAL.99    
         SV(IP+IV*NWJ2)=SV(IP+IV*NWJ2) + POLY(IP+NWJ2,1)*GV(IM+IV*IDL)     LEGUP1.19    
   40    CONTINUE                                                          LEGUP1.20    
      ELSE                                                                 HANAL.101   
         IM=-IDL                                                           HANAL.102   
         IP=-NWJ2                                                          HANAL.103   
         DO 50 MP=1,MFP,MOCT                                               HANAL.104   
         IM=IM+1                                                           HANAL.105   
         DO 50 IN=MP,NFP,MH                                                HANAL.106   
         IP=IP+1                                                           HANAL.107   
CDIR$    IVDEP                                                             BUGS5.24    
         DO 50 IV=1,NLS*NHEM,2                                             BUGS5.25    
         IW=IV+1                                                           BUGS5.26    
         SV(IP+IV*NWJ2)=SV(IP+IV*NWJ2) + POLY(IP+NWJ2,1)*GVW(IM+IV*IDL)    LEGUP1.21    
         SV(IP+IW*NWJ2)=SV(IP+IW*NWJ2) + POLY(IP+NWJ2,2)*GVW(IM+IW*IDL)    LEGUP1.22    
   50    CONTINUE                                                          LEGUP1.23    
      ENDIF                                                                HANAL.111   
C                                                                          HANAL.112   
      RETURN                                                               HANAL.113   
      END                                                                  HANAL.114   
C     ****************************************************************     HANAL.115   
*DECK GRMULT                                                               GRMULT.1     
      SUBROUTINE GRMULT                                                    GRMULT.2     
C                                                                          GRMULT.3     
C     Control routine for all grid point calculations in main loop.        GRMULT.4     
C     JH in common LEGAU contains latitude row number.                     GRMULT.5     
C                                                                          GRMULT.6     
*CALL PARAM1                                                               GRMULT.7     
*CALL PARAM2                                                               GRMULT.8     
*CALL BATS                                                                 GRMULT.9     
*CALL BLANK                                                                GRMULT.10    
*CALL COMGRM                                                               GRMULT.11    
*CALL COMPRL                                                               GRMULT.12    
*CALL GRIDP                                                                GRMULT.13    
*CALL OUTCON                                                               GRMULT.14    
C                                                                          GRMULT.15    
C     Full fields of non-dimensional temperature and surface pressure.     GRMULT.16    
C                                                                          GRMULT.17    
      DO 10 I=1,IGC                                                        GRMULT.18    
   10 PLG(I)=EXP(PLG(I))                                                   GRMULT.19    
      K=0                                                                  GRMULT.20    
      DO 20 L=1,NL                                                         GRMULT.21    
      DO 20 I=1,IGC                                                        GRMULT.22    
      K=K+1                                                                GRMULT.23    
      TG(K)=TG(K)+TMEAN(L)                                                 GRMULT.24    
   20 CONTINUE                                                             GRMULT.25    
C                                                                          GRMULT.26    
C     Model level pressures.                                               GRMULT.27    
      CALL PSGCR                                                           GRMULT.28    
C                                                                          GRMULT.29    
C     Non-linear parameterised momentum tendencies.                        GRMULT.30    
      CALL NTEND                                                           GRMULT.31    
C                                                                          GRMULT.32    
C     Geopotential height.                                                 GRMULT.33    
      CALL GHGCR                                                           GRMULT.34    
C                                                                          GRMULT.35    
C     Omega.                                                               GRMULT.36    
      CALL OMGCR                                                           GRMULT.37    
C                                                                          GRMULT.38    
C     MSL pressure and surface fields used for extrapolation.              GRMULT.39    
      CALL SRFCR                                                           GRMULT.40    
C                                                                          GRMULT.41    
C     Vertical derivative terms.                                           GRMULT.42    
      IF (LINTP2.OR.(LPC6.AND.LOUT)) THEN                                  GRMULT.43    
         CALL DLSGCR(IGC,UG,RGG,DUDLSG,IGC,NL)                             GRMULT.44    
         CALL DLSGCR(IGC,VG,RGG,DVDLSG,IGC,NL)                             GRMULT.45    
         CALL DLSGCR(IGC,TG,RGG,DTDLSG,IGC,NL)                             GRMULT.46    
      ENDIF                                                                GRMULT.47    
C                                                                          GRMULT.48    
C     Ertel potential vorticity and interpolation to isentropic levels.    GRMULT.49    
      IF (LPC6.AND.LOUT) CALL PVCR                                         GRMULT.50    
C                                                                          GRMULT.51    
C     Interpolation to isobaric levels if required.                        GRMULT.52    
      IF (LINTP2) THEN                                                     GRMULT.53    
         CALL DVPCOR                                                       GRMULT.54    
         CALL INTPR                                                        GRMULT.55    
      ENDIF                                                                GRMULT.56    
C                                                                          GRMULT.57    
      RETURN                                                               GRMULT.58    
      END                                                                  GRMULT.59    
C     ****************************************************************     GRMULT.60    
*DECK PSGCR                                                                PSGCR.1     
      SUBROUTINE PSGCR                                                     PSGCR.2     
C                                                                          PSGCR.3     
C     Calculate pressures on full model levels.                            PSGCR.4     
C     Find max and min pressure for each level / latitude row.             PSGCR.5     
C     Reading model - trivial for sigma co-ords.                           PSGCR.6     
C                                                                          PSGCR.7     
*CALL PARAM1                                                               PSGCR.8     
*CALL PARAM2                                                               PSGCR.9     
*CALL BLANK                                                                PSGCR.10    
*CALL COMPRL                                                               PSGCR.11    
*CALL GRIDP                                                                PSGCR.12    
      DO 40 L=1,NL                                                         ANSI2.308   
C                                                                          ANSI2.309   
         DO 10 II=1,IGC                                                    ANSI2.310   
            PSG(II,L)=SIGMA(L)*PLG(II)                                     ANSI2.311   
   10    CONTINUE                                                          ANSI2.312   
C                                                                          ANSI2.313   
         DO 20 IHEM=1,NHEM                                                 ANSI2.314   
            IOF=(IHEM-1)*MGPP                                              ANSI2.315   
            ZPMAX=PSG(IOF+1,L)                                             ANSI2.316   
            ZPMIN=PSG(IOF+1,L)                                             ANSI2.317   
            DO 30 II=2+IOF,MG+IOF                                          ANSI2.318   
               ZPMAX=MAX(ZPMAX,PSG(II,L))                                  ANSI2.319   
               ZPMIN=MIN(ZPMIN,PSG(II,L))                                  ANSI2.320   
   30       CONTINUE                                                       ANSI2.321   
            PSGMX(L,IHEM)=ZPMAX                                            ANSI2.322   
            PSGMN(L,IHEM)=ZPMIN                                            ANSI2.323   
   20    CONTINUE                                                          ANSI2.324   
C                                                                          ANSI2.325   
   40 CONTINUE                                                             ANSI2.326   
C                                                                          PSGCR.24    
      RETURN                                                               PSGCR.25    
      END                                                                  PSGCR.26    
C     ****************************************************************     PSGCR.27    
*DECK NTEND                                                                NTEND.1     
      SUBROUTINE NTEND                                                     NTEND.2     
C                                                                          NTEND.3     
C     Calculate non-linear momentum tendencies from boundary layer and     NTEND.4     
C     vertical diffusion schemes, if included.  Used in GDIAG for          NTEND.5     
C     global energetics, plus fields may also be printed/plotted.          NTEND.6     
C     Applies parameterisation schemes from the simple GCM (SGCM)          NTEND.7     
C     PDN=BGCM5,ID=UPLIB,ED=5 to the history file data at the current      NTEND.8     
C     analysis time.  Note that the tendencies in the model are slightly   NTEND.9     
C     different since they are computed in a split timestep there.         NTEND.10    
C                                                                          NTEND.11    
*CALL PARAM1                                                               NTEND.12    
*CALL PARAM2                                                               NTEND.13    
*CALL BATS                                                                 NTEND.14    
*CALL BLANK                                                                NTEND.15    
*CALL GRIDP                                                                NTEND.16    
*CALL LEGAU                                                                NTEND.17    
*CALL PHYS                                                                 NTEND.18    
      REAL FA(NL),BVP(MG),BVM(MG)                                          NTEND.19    
C                                                                          NTEND.20    
C     Zero presets.  No calculations if parameterisations not switched     NTEND.21    
C     on at current analysis time.                                         NTEND.22    
C                                                                          NTEND.23    
      DO 10 I=1,IGD                                                        NTEND.24    
      FUG(I)=0.0                                                           NTEND.25    
      FVG(I)=0.0                                                           NTEND.26    
   10 CONTINUE                                                             NTEND.27    
      IF (KOUNT.LE.KBEGP) RETURN                                           NTEND.28    
C                                                                          NTEND.29    
C     Boundary layer scheme.                                               NTEND.30    
C     Momentum tendencies at lowest model level associated with surface    NTEND.31    
C     fluxes.  Bulk aerodynamic formula without stability dependence.      NTEND.32    
C                                                                          NTEND.33    
      IF (LBL) THEN                                                        NTEND.34    
      DO 30 IHEM=1,NHEM                                                    NTEND.35    
      JOF=NLM*IGC + (IHEM-1)*MGPP                                          NTEND.36    
      BLCONJ=BLCON/TSTAR(JH,IHEM)                                          NTEND.37    
      DO 20 I=1,MG                                                         NTEND.38    
      J=JOF+I                                                              NTEND.39    
      VM=SQRT(SECSQ(JH)*(UG(J)*UG(J)+VG(J)*VG(J)))                         NTEND.40    
      CMODV=BLCONJ*(VM+BLVAD)                                              NTEND.41    
      FUG(J)=FUG(J)-CMODV*UG(J)                                            NTEND.42    
      FVG(J)=FVG(J)-CMODV*VG(J)                                            NTEND.43    
   20 CONTINUE                                                             NTEND.44    
   30 CONTINUE                                                             NTEND.45    
      ENDIF                                                                NTEND.46    
C                                                                          NTEND.47    
C     Vertical diffusion scheme.                                           NTEND.48    
C     Linear diffusive flux throughout model depth with constant coeff.    NTEND.49    
C                                                                          NTEND.50    
      IF (LVD) THEN                                                        NTEND.51    
      DO 100 L=1,NL                                                        NTEND.52    
  100 FA(L)=1.0/DSIGMA(L)                                                  NTEND.53    
      DO 140 IHEM=1,NHEM                                                   NTEND.54    
      IOFM=(IHEM-1)*MGPP                                                   NTEND.55    
      DO 110 I=1,MG                                                        NTEND.56    
      J=I+IOFM                                                             NTEND.57    
      JP=J+IGC                                                             NTEND.58    
      TLPH=TG(JP)+TG(J)                                                    NTEND.59    
      FTSQ=FB(1)/(TLPH*TLPH)                                               NTEND.60    
      BVP(I)=AKVV*FTSQ                                                     NTEND.61    
      FUG(J)=FUG(J)+FA(1)*BVP(I)*(UG(JP)-UG(J))                            NTEND.62    
      FVG(J)=FVG(J)+FA(1)*BVP(I)*(VG(JP)-VG(J))                            NTEND.63    
  110 CONTINUE                                                             NTEND.64    
      DO 120 L=2,NLM                                                       NTEND.65    
      JOF=(L-1)*IGC+IOFM                                                   NTEND.66    
      DO 120 I=1,MG                                                        NTEND.67    
      J=JOF+I                                                              NTEND.68    
      JP=J+IGC                                                             NTEND.69    
      JM=J-IGC                                                             NTEND.70    
      BVM(I)=BVP(I)                                                        NTEND.71    
      TLPH=TG(JP)+TG(J)                                                    NTEND.72    
      FTSQ=FB(L)/(TLPH*TLPH)                                               NTEND.73    
      BVP(I)=AKVV*FTSQ                                                     NTEND.74    
      FUG(J)=FUG(J)+FA(L)*(BVP(I)*(UG(JP)-UG(J))-BVM(I)*(UG(J)-UG(JM)))    NTEND.75    
      FVG(J)=FVG(J)+FA(L)*(BVP(I)*(VG(JP)-VG(J))-BVM(I)*(VG(J)-VG(JM)))    NTEND.76    
  120 CONTINUE                                                             NTEND.77    
      JOF=NLM*IGC+IOFM                                                     NTEND.78    
      DO 130 I=1,MG                                                        NTEND.79    
      J=JOF+I                                                              NTEND.80    
      JM=J-IGC                                                             NTEND.81    
      FUG(J)=FUG(J)-FA(NL)*BVP(I)*(UG(J)-UG(JM))                           NTEND.82    
      FVG(J)=FVG(J)-FA(NL)*BVP(I)*(VG(J)-VG(JM))                           NTEND.83    
  130 CONTINUE                                                             NTEND.84    
  140 CONTINUE                                                             NTEND.85    
      ENDIF                                                                NTEND.86    
C                                                                          NTEND.87    
      RETURN                                                               NTEND.88    
      END                                                                  NTEND.89    
C     ****************************************************************     NTEND.90    
*DECK GHGCR                                                                GHGCR.1     
      SUBROUTINE GHGCR                                                     GHGCR.2     
C                                                                          GHGCR.3     
C     Compute geopotential height field.  Integrate hydrostatic            GHGCR.4     
C     equation and add orography if non-zero.  Resulting array GHG         GHGCR.5     
C     is geopotential non-dimensionalsed by CG.                            GHGCR.6     
C     NB. Called from GRMULT so TG contains full temperature inc TMEAN.    GHGCR.7     
C     Reading model - sigma.                                               GHGCR.8     
C                                                                          GHGCR.9     
*CALL PARAM1                                                               GHGCR.10    
*CALL PARAM2                                                               GHGCR.11    
*CALL BATS                                                                 GHGCR.12    
*CALL BLANK                                                                GHGCR.13    
*CALL COMROG                                                               GHGCR.14    
*CALL GRIDP                                                                GHGCR.15    
*CALL LEGAU                                                                GHGCR.16    
C                                                                          GHGCR.17    
C     Zero preset.                                                         GHGCR.18    
C                                                                          GHGCR.19    
      DO 10 I=1,IGD                                                        GHGCR.20    
   10 GHG(I)=0.                                                            GHGCR.21    
C                                                                          GHGCR.22    
C     Integrate hydrostatic equation.                                      GHGCR.23    
C                                                                          GHGCR.24    
      IL=0                                                                 GHGCR.25    
      DO 20 L=1,NL                                                         GHGCR.26    
      DO 20 K=1,NL                                                         GHGCR.27    
      IL=IL+1                                                              GHGCR.28    
      GG=G(IL)                                                             GHGCR.29    
      DO 20 IHEM=1,NHEM                                                    GHGCR.30    
      II=(L-1)*IGC+(IHEM-1)*MGPP                                           GHGCR.31    
      IKK=(K-1)*IGC+(IHEM-1)*MGPP                                          GHGCR.32    
      DO 20 I=1,MG                                                         GHGCR.33    
      II=II+1                                                              GHGCR.34    
      IKK=IKK+1                                                            GHGCR.35    
   20 GHG(II)=GHG(II)+GG*TG(IKK)                                           GHGCR.36    
C                                                                          GHGCR.37    
C     Optionally add orography.                                            GHGCR.38    
C                                                                          GHGCR.39    
      IF (LROG) THEN                                                       GHGCR.40    
         DO 30 IHEM=1,NHEM                                                 GHGCR.41    
         IOF=(IHEM-1)*MGPP                                                 GHGCR.42    
         DO 30 L=1,NL                                                      GHGCR.43    
         K=(L-1)*IGC+IOF                                                   GHGCR.44    
         DO 30 I=1,MG                                                      GHGCR.45    
         K=K+1                                                             GHGCR.46    
   30    GHG(K)=GHG(K)+GSG(I+IOF,JL)                                       GHGCR.47    
      ENDIF                                                                GHGCR.48    
C                                                                          GHGCR.49    
      RETURN                                                               GHGCR.50    
      END                                                                  GHGCR.51    
C     ****************************************************************     GHGCR.52    
*DECK OMGCR                                                                OMGCR.1     
      SUBROUTINE OMGCR                                                     OMGCR.2     
C                                                                          OMGCR.3     
C     Calculate omega on full model levels.                                OMGCR.4     
C     Reading model - sigma.                                               OMGCR.5     
C                                                                          OMGCR.6     
*CALL PARAM1                                                               OMGCR.7     
*CALL PARAM2                                                               OMGCR.8     
*CALL BLANK                                                                OMGCR.9     
*CALL BATS                                                                 VOPT1.48    
*CALL COMPRL                                                               OMGCR.10    
*CALL GRIDP                                                                OMGCR.11    
*CALL LEGAU                                                                OMGCR.12    
      REAL SGVDP(IGC)                                                      VOPT1.49    
C                                                                          VOPT1.50    
C     Preset.                                                              VOPT1.51    
C                                                                          VOPT1.52    
      DO 10 I=1,IGD                                                        VOPT1.53    
         OMG(I)=0.                                                         VOPT1.54    
   10 CONTINUE                                                             VOPT1.55    
      DO 20 I=1,IGC                                                        VOPT1.56    
         SGVDP(I)=0.                                                       VOPT1.57    
   20 CONTINUE                                                             VOPT1.58    
C                                                                          VOPT1.59    
C     Main loop over latitude pair.                                        VOPT1.60    
C                                                                          VOPT1.61    
      DO 100 IHEM=1,NHEM                                                   VOPT1.62    
         IOF=(IHEM-1)*MGPP                                                 VOPT1.63    
C                                                                          VOPT1.64    
C        Main level loop, including vertical integral of SGVDP.            VOPT1.65    
C                                                                          VOPT1.66    
         DO 90 L=1,NL                                                      VOPT1.67    
            IOFL=(L-1)*IGC                                                 VOPT1.68    
            BETAL=G((L-1)*NL+L)                                            VOPT1.69    
C                                                                          VOPT1.70    
C           Compute separate terms and sum for omega.                      VOPT1.71    
C                                                                          VOPT1.72    
            DO 80 II=1+IOF,MG+IOF                                          VOPT1.73    
               K=II+IOFL                                                   VOPT1.74    
               VGPG=SECSQ(JH)*(UG(K)*PMG(II)+VG(K)*PJG(II))                VOPT1.75    
               GVDP=(DG(K)+VGPG)*DSIGMA(L)                                 VOPT1.76    
               TERM=BETAL*GVDP + ALPHA(L)*SGVDP(II)                        VOPT1.77    
               OMG(K)=SIGMA(L)*PLG(II)*(VGPG-TERM/DSIGMA(L))               VOPT1.78    
               SGVDP(II)=SGVDP(II)+GVDP                                    VOPT1.79    
   80       CONTINUE                                                       VOPT1.80    
C                                                                          VOPT1.81    
   90    CONTINUE                                                          VOPT1.82    
  100 CONTINUE                                                             VOPT1.83    
C                                                                          OMGCR.45    
      RETURN                                                               OMGCR.46    
      END                                                                  OMGCR.47    
C     ****************************************************************     OMGCR.48    
*DECK SRFCR                                                                SRFCR.1     
      SUBROUTINE SRFCR                                                     SRFCR.2     
C                                                                          SRFCR.3     
C     Calculate various surface and low level fields for extrapolation     SRFCR.4     
C     below lowest model level (based on constant lapse rate). Also        SRFCR.5     
C     calculate msl pressure.                                              SRFCR.6     
C     Reading model - sigma.                                               SRFCR.7     
C                                                                          SRFCR.8     
*CALL PARAM1                                                               SRFCR.9     
*CALL PARAM2                                                               SRFCR.10    
*CALL BLANK                                                                SRFCR.11    
*CALL COMGRM                                                               SRFCR.12    
*CALL COMPRL                                                               SRFCR.13    
*CALL COMROG                                                               SRFCR.14    
*CALL GRIDP                                                                SRFCR.15    
*CALL LEGAU                                                                SRFCR.16    
C                                                                          SRFCR.17    
C     Default settings for no orography.  Surface temperature extrap       SRFCR.18    
C     from lowest model level using XLAPSE constant lapse rate.            SRFCR.19    
C     Surface pressure copied from PLG (INTER cannot call /GRIDP/).        SRFCR.20    
C     MSL pressure just a copy of surface value.                           SRFCR.21    
C                                                                          SRFCR.22    
      SIGFAC=SIGMA(NL)**(-XLAPSE)                                          SRFCR.23    
      LOF=NLM*IGC                                                          SRFCR.24    
      DO 10 II=1,IGC                                                       SRFCR.25    
      TSRF(II)=TG(LOF+II)*SIGFAC                                           SRFCR.26    
      PSRF(II)=PLG(II)                                                     SRFCR.27    
      PMSLG(II)=PLG(II)                                                    SRFCR.28    
   10 CONTINUE                                                             SRFCR.29    
C                                                                          SRFCR.30    
C     Surface omega from integral of continuity eqaution.                  SRFCR.31    
C                                                                          SRFCR.32    
      DO 20 II=1,IGC                                                       SRFCR.33    
   20 OMSRF(II)=0.                                                         SRFCR.34    
      DO 30 L=1,NL                                                         SRFCR.35    
      IOF=(L-1)*IGC                                                        SRFCR.36    
      DO 30 II=1,IGC                                                       SRFCR.37    
      K=IOF+II                                                             SRFCR.38    
      VGP=SECSQ(JH)*(UG(K)*PMG(II)+VG(K)*PJG(II))                          SRFCR.39    
   30 OMSRF(II)=OMSRF(II)-(VGP+DG(K))*DSIGMA(L)                            SRFCR.40    
      DO 40 II=1,IGC                                                       SRFCR.41    
   40 OMSRF(II)=OMSRF(II)*PLG(II)                                          SRFCR.42    
C                                                                          SRFCR.43    
C     Extrapolation to msl if orography present.                           SRFCR.44    
C                                                                          SRFCR.45    
      IF (LROG) THEN                                                       SRFCR.46    
         RXLAPS=1./XLAPSE                                                  SRFCR.47    
         DO 50 IHEM=1,NHEM                                                 SRFCR.48    
         IOF=(IHEM-1)*MGPP                                                 SRFCR.49    
         DO 50 I=1,MG                                                      SRFCR.50    
         II=I+IOF                                                          SRFCR.51    
         PMSLG(II)=PLG(II)*((1.+XLAPSE*GSG(II,JL)/TSRF(II))**RXLAPS)       SRFCR.52    
   50    CONTINUE                                                          SRFCR.53    
      ENDIF                                                                SRFCR.54    
C                                                                          SRFCR.55    
      RETURN                                                               SRFCR.56    
      END                                                                  SRFCR.57    
C     ****************************************************************     SRFCR.58    
*DECK DLSGCR                                                               DLSGCR.1     
      SUBROUTINE DLSGCR(NCOL,F,RGG,DF,IDIM,NL)                             DLSGCR.2     
C                                                                          DLSGCR.3     
C     Black-box routine to take vertical derivative of a 2D array          DLSGCR.4     
C     in the model's vertical co-ordinates using the RGG matrix:           DLSGCR.5     
C                                                                          DLSGCR.6     
C              DF   =   RGG   *   F                                        DLSGCR.7     
C                                                                          DLSGCR.8     
C     gives    DF   =   d(F)/dln(sigma)   =   (sigma)d(F)/d(sigma).        DLSGCR.9     
C                                                                          DLSGCR.10    
C     Calculates DF at NL levels for NCOL columns from the array F.        DLSGCR.11    
C     Uses vector loops over NCOL at each level.  Note that for            DLSGCR.12    
C     NCOL <= 3 inner loops unroll to give vectorisation over levels.      DLSGCR.13    
C                                                                          DLSGCR.14    
C     Uses explicit values of RGG matrix rather than function SDOT         DLSGCR.15    
C     over NL elements of RGG at each level.  Due to sparse nature         DLSGCR.16    
C     of RGG, this gives large speed-up for NL >> 3.                       DLSGCR.17    
C                                                                          DLSGCR.18    
C     Reading model - sigma.                                               DLSGCR.19    
C                                                                          DLSGCR.20    
      REAL F(IDIM,NL),DF(IDIM,NL),RGG(NL,NL)                               DLSGCR.21    
C                                                                          DLSGCR.22    
 6900 FORMAT(/' ***ABORT IN DLSGCR: MORE COLUMNS THAN ARRAY DIMENSION:'    DLSGCR.23    
     :       ,' NCOL IDIM =',2I10)                                         ANSI2.327   
C                                                                          DLSGCR.25    
      IF (NCOL.GT.IDIM) THEN                                               DLSGCR.26    
         WRITE(6,6900) NCOL,IDIM                                           DLSGCR.27    
         CALL ABORT                                                        DLSGCR.28    
      ENDIF                                                                DLSGCR.29    
C                                                                          DLSGCR.30    
      NLM=NL-1                                                             DLSGCR.31    
      NLMM=NL-2                                                            DLSGCR.32    
C     Top and bottom levels.                                               DLSGCR.33    
      DO 10 I=1,NCOL                                                       DLSGCR.34    
      DF(I,1 )=F(I,1)*RGG(1,1)+F(I,2)*RGG(2,1)+F(I,3)*RGG(3,1)             DLSGCR.35    
      DF(I,NL)=F(I,NLMM)*RGG(NLMM,NL)+F(I,NLM)*RGG(NLM,NL)                 DLSGCR.36    
     :        +F(I,NL)*RGG(NL,NL)                                          DLSGCR.37    
   10 CONTINUE                                                             DLSGCR.38    
C     Intermediate levels.                                                 DLSGCR.39    
      DO 20 L=2,NLM                                                        DLSGCR.40    
      DO 20 I=1,NCOL                                                       DLSGCR.41    
      DF(I,L)=F(I,L-1)*RGG(L-1,L)+F(I,L+1)*RGG(L+1,L)                      DLSGCR.42    
   20 CONTINUE                                                             DLSGCR.43    
C                                                                          DLSGCR.44    
      RETURN                                                               DLSGCR.45    
      END                                                                  DLSGCR.46    
C     ****************************************************************     DLSGCR.47    
*DECK PVCR                                                                 PVCR.1     
      SUBROUTINE PVCR                                                      PVCR.2     
C                                                                          PVCR.3     
C     Calculate potential temperature and Ertel potential vorticity        PVCR.4     
C     on model levels.                                                     PVCR.5     
C     Interpolate PV, pressure and winds to isentropic levels.             PVCR.6     
C     Reading model - sigma.                                               PVCR.7     
C                                                                          PVCR.8     
*CALL PARAM1                                                               PVCR.9     
*CALL PARAM2                                                               PVCR.10    
*CALL BLANK                                                                PVCR.11    
*CALL COMGRM                                                               PVCR.12    
*CALL COMPRL                                                               PVCR.13    
*CALL GRIDP                                                                PVCR.14    
*CALL LEGAU                                                                PVCR.15    
*CALL OUTCON                                                               PVCR.16    
      DO 100 IHEM=1,NHEM                                                   PVCR.17    
      IOF=(IHEM-1)*MGPP                                                    PVCR.18    
C                                                                          PVCR.19    
C     Calculate potential temperature and PV on model levels.              PVCR.20    
C     Generalised formula using array of model level pressures is used     PVCR.21    
C     to calculate potential temperature.  But note that the reference     PVCR.22    
C     pressure for adiabatic processes is assumed to be P0, the non-       PVCR.23    
C     dimensionalising pressure.                                           PVCR.24    
C                                                                          PVCR.25    
      DO 10 L=1,NL                                                         PVCR.26    
      K=(L-1)*IGC+IOF                                                      PVCR.27    
      DO 10 I=1,MG                                                         PVCR.28    
      II=I+IOF                                                             PVCR.29    
      K=K+1                                                                PVCR.30    
      PMKG=PSG(II,L)**(-AKAP)                                              PVCR.31    
      PM1KG=PMKG/PSG(II,L)                                                 PVCR.32    
      AKT=AKAP*TG(K)                                                       PVCR.33    
      TXP=TXG(K)-AKT*PMG(II)                                               PVCR.34    
      TYP=TYG(K)-AKT*PJG(II)                                               PVCR.35    
      THG(K)=TG(K)*PMKG                                                    PVCR.36    
      EPVG(K)=PM1KG*(ZG(K)*(-DTDLSG(II,L)+AKT)                             PVCR.37    
     :                 +SECSQ(JH)*(-DUDLSG(II,L)*TYP+DVDLSG(II,L)*TXP))    PVCR.38    
   10 CONTINUE                                                             PVCR.39    
C                                                                          PVCR.40    
C     Interpolate to theta surfaces. First set up array containing         PVCR.41    
C     model level directly above required theta level.                     PVCR.42    
C     NB.  ON=J in CFT will give bounds errors in 20 loop (LMIN>NL).       PVCR.43    
C                                                                          PVCR.44    
      DO 40 I=1,MG                                                         PVCR.45    
      II=I+IOF                                                             PVCR.46    
      LM=1                                                                 PVCR.47    
      DO 40 NSF=1,NTHSF                                                    PVCR.48    
      LMIN=LM+1                                                            PVCR.49    
      DO 20 L=LMIN,NLM                                                     PVCR.50    
      K=(L-1)*IGC+II                                                       PVCR.51    
      IF (THSURF(NSF).GT.THG(K)) GOTO 30                                   PVCR.52    
   20 LM=LM+1                                                              PVCR.53    
   30 INTRL(II,NSF)=LM                                                     PVCR.54    
   40 CONTINUE                                                             PVCR.55    
C                                                                          PVCR.56    
C     Set up factor and interpolate linearly in theta.                     PVCR.57    
C                                                                          PVCR.58    
      DO 50 NSF=1,NTHSF                                                    PVCR.59    
      N=(NSF-1)*IGC+IOF                                                    PVCR.60    
      DO 50 I=1,MG                                                         PVCR.61    
      II=I+IOF                                                             PVCR.62    
      N=N+1                                                                PVCR.63    
      LM=INTRL(II,NSF)                                                     PVCR.64    
      KM=(LM-1)*IGC+II                                                     PVCR.65    
      KP=KM+IGC                                                            PVCR.66    
      FACT=(THSURF(NSF)-THG(KM))/(THG(KP)-THG(KM))                         PVCR.67    
      UTHG(N)=UG(KM)+FACT*(UG(KP)-UG(KM))                                  PVCR.68    
      VTHG(N)=VG(KM)+FACT*(VG(KP)-VG(KM))                                  PVCR.69    
      ERTHG(N)=EPVG(KM)+FACT*(EPVG(KP)-EPVG(KM))                           PVCR.70    
      PTHG(N)=PSG(II,LM)+FACT*(PSG(II,LM+1)-PSG(II,LM))                    PVCR.71    
   50 CONTINUE                                                             PVCR.72    
C                                                                          PVCR.73    
C     Finally flag points below lowest model level with values             PVCR.74    
C     suitable for plotting.                                               PVCR.75    
C                                                                          PVCR.76    
      LOF=NLM*IGC                                                          PVCR.77    
      DO 60 NSF=1,NTHSF                                                    PVCR.78    
      K=(NSF-1)*IGC+IOF                                                    PVCR.79    
      DO 60 I=1,MG                                                         PVCR.80    
      II=I+IOF                                                             PVCR.81    
      K=K+1                                                                PVCR.82    
      IF (THSURF(NSF).LT.THG(LOF+II)) THEN                                 PVCR.83    
         UTHG(K)=1.                                                        PVCR.84    
         VTHG(K)=0.                                                        PVCR.85    
         ERTHG(K)=0.                                                       PVCR.86    
         PTHG(K)=1.2                                                       PVCR.87    
      ENDIF                                                                PVCR.88    
   60 CONTINUE                                                             PVCR.89    
C                                                                          PVCR.90    
  100 CONTINUE                                                             PVCR.91    
C                                                                          PVCR.92    
      RETURN                                                               PVCR.93    
      END                                                                  PVCR.94    
C     ****************************************************************     PVCR.95    
*DECK DVPCOR                                                               DVPCOR.1     
      SUBROUTINE DVPCOR                                                    DVPCOR.2     
C                                                                          DVPCOR.3     
C     If interpolating grid point fields from model to isobaric levels,    DVPCOR.4     
C     correct model level vorticity and divergence to those using          DVPCOR.5     
C     gradient operator on pressure surfaces, but leaving fields on        DVPCOR.6     
C     model levels.                                                        DVPCOR.7     
C     Reading model - sigma.                                               DVPCOR.8     
C                                                                          DVPCOR.9     
*CALL PARAM1                                                               DVPCOR.10    
*CALL PARAM2                                                               DVPCOR.11    
*CALL COMGRM                                                               DVPCOR.12    
*CALL GRIDP                                                                DVPCOR.13    
*CALL LEGAU                                                                DVPCOR.14    
      DO 10 IHEM=1,NHEM                                                    DVPCOR.15    
      IOF=(IHEM-1)*MGPP                                                    DVPCOR.16    
      DO 10 L=1,NL                                                         DVPCOR.17    
      K=(L-1)*IGC+IOF                                                      DVPCOR.18    
      DO 10 I=1,MG                                                         DVPCOR.19    
      II=I+IOF                                                             DVPCOR.20    
      K=K+1                                                                DVPCOR.21    
      ZG(K)=ZG(K)-SECSQ(JH)*(DVDLSG(II,L)*PMG(II)-DUDLSG(II,L)*PJG(II))    DVPCOR.22    
      DG(K)=DG(K)-SECSQ(JH)*(DUDLSG(II,L)*PMG(II)+DVDLSG(II,L)*PJG(II))    DVPCOR.23    
   10 CONTINUE                                                             DVPCOR.24    
C                                                                          DVPCOR.25    
      RETURN                                                               DVPCOR.26    
      END                                                                  DVPCOR.27    
C     ****************************************************************     DVPCOR.28    
*DECK INTPR                                                                INTPR.1     
      SUBROUTINE INTPR                                                     INTPR.2     
C                                                                          INTPR.3     
C     Interpolate from model levels to isobaric levels.                    INTPR.4     
C     Can be called from either GRMULT or FLUX, depending on switches      INTPR.5     
C     LINTP2, LINTP3 in common COMPRL.                                     INTPR.6     
C     Extra fields are interpolated when called from GRMULT.               INTPR.7     
C     Reading model - sigma.                                               INTPR.8     
C     NB.  Arrays DUDLSG, DVDLSG in common COMGRM are used as workspace.   INTPR.9     
C                                                                          INTPR.10    
*CALL PARAM1                                                               INTPR.11    
*CALL PARAM2                                                               INTPR.12    
*CALL COMGRM                                                               INTPR.13    
*CALL COMPRL                                                               INTPR.14    
*CALL GRIDP                                                                INTPR.15    
      REAL FINTR(IGC,NL),WKINT(IGC,NL)                                     INTPR.16    
      EQUIVALENCE (FINTR(1,1),DUDLSG(1,1)),(WKINT(1,1),DVDLSG(1,1))        INTPR.17    
      LOGICAL LFIRST                                                       VOPT1.1     
C                                                                          INTPR.18    
      DO 100 IHEM=1,NHEM                                                   INTPR.19    
      IOF=(IHEM-1)*MGPP                                                    INTPR.20    
C                                                                          INTPR.21    
C     The following code has been optimised by placing the longitude       VOPT1.2     
C     loop (20) innermost but this requires extra complexity to minimise   VOPT1.3     
C     the number of computations.                                          VOPT1.4     
C      Note: it is assumed that both input and output levels are ordered   VOPT1.5     
C     monotonically in increasing pressure.                                VOPT1.6     
C      The INTRL array is preset to NLM for each output level, covering    VOPT1.7     
C     all cases for which the output level is lower than the second last   VOPT1.8     
C     input level, including those below the lowest level, which the       VOPT1.9     
C     subsequent code will not find.                                       VOPT1.10    
C      The first level is not searched because extrapolation will be       VOPT1.11    
C     performed using the gradient between the first two levels.           VOPT1.12    
C      The input layers are then searched for the output pressure down     VOPT1.13    
C     to NLM only, because of the preset.  Contiguous layers from the      VOPT1.14    
C     top with no count can be skipped for subsequent output levels,       VOPT1.15    
C     allowing LBEG to be incremented.  The search is terminated once      VOPT1.16    
C     all points are found.                                                VOPT1.17    
C                                                                          VOPT1.18    
C     First set up array INTRL containing model level directly above       INTPR.22    
C     required pressure level.                                             INTPR.23    
C                                                                          INTPR.24    
      LBEG=2                                                               VOPT1.19    
      DO 35 N=1,NLPR                                                       VOPT1.20    
C                                                                          VOPT1.21    
      DO 10 II=IOF+1,IOF+MG                                                VOPT1.22    
      INTRL(II,N)=NLM                                                      VOPT1.23    
   10 CONTINUE                                                             VOPT1.24    
C                                                                          VOPT1.25    
      ICOUNT=0                                                             VOPT1.26    
      LMIN=LBEG                                                            VOPT1.27    
      DO 30 L=LMIN,NLM                                                     VOPT1.28    
      DO 20 II=IOF+1,IOF+MG                                                VOPT1.29    
C     Check INTRL to find only first occurrence in column.                 VOPT1.30    
      LFIRST=INTRL(II,N).EQ.NLM                                            VOPT1.31    
      IF (LFIRST.AND.PPR(N).LE.PSG(II,L)) THEN                             VOPT1.32    
         ICOUNT=ICOUNT+1                                                   VOPT1.33    
         INTRL(II,N)=L-1                                                   VOPT1.34    
      ENDIF                                                                VOPT1.35    
   20 CONTINUE                                                             VOPT1.36    
      IF (ICOUNT.EQ.0) THEN                                                VOPT1.37    
         LBEG=LBEG+1                                                       VOPT1.38    
      ELSE IF (ICOUNT.EQ.MG) THEN                                          VOPT1.39    
         GOTO 35                                                           VOPT1.40    
      ENDIF                                                                VOPT1.41    
   30 CONTINUE                                                             VOPT1.42    
C                                                                          VOPT1.43    
   35 CONTINUE                                                             VOPT1.44    
C                                                                          INTPR.35    
C     Set up interpolation factors in array FINTR for linear               INTPR.36    
C     interpolation in ln(p).                                              INTPR.37    
C                                                                          INTPR.38    
      DO 40 N=1,NLPR                                                       INTPR.39    
      DO 40 I=1,MG                                                         INTPR.40    
      II=I+IOF                                                             INTPR.41    
      LM=INTRL(II,N)                                                       INTPR.42    
      LP=LM+1                                                              INTPR.43    
      FINTR(II,N)=LOG(PPR(N)/PSG(II,LM))/LOG(PSG(II,LP)/PSG(II,LM))        VOPT1.45    
   40 CONTINUE                                                             VOPT1.46    
C                                                                          INTPR.45    
  100 CONTINUE                                                             INTPR.46    
C                                                                          INTPR.47    
C     Finally interpolate and extrapolate fields.                          INTPR.48    
C     Extra fields required if called from GRMULT (LINTP2=.TRUE.).         VOPT1.47    
C     Final two arguments are switches for upward and downward extrap      INTPR.50    
C     respectively.  See INTER for details.                                INTPR.51    
C                                                                          INTPR.52    
      IF (LINTP2) THEN                                                     INTPR.53    
         CALL INTER(ZG ,WKINT,NLPR,INTRL,FINTR,1,1,0)                      INTPR.54    
         CALL INTER(DG ,WKINT,NLPR,INTRL,FINTR,1,0,0)                      INTPR.55    
         CALL INTER(GHG,WKINT,NLPR,INTRL,FINTR,1,1,4)                      INTPR.56    
      ENDIF                                                                INTPR.57    
      CALL INTER(OMG,WKINT,NLPR,INTRL,FINTR,1,2,2)                         INTPR.58    
      CALL INTER(UG ,WKINT,NLPR,INTRL,FINTR,1,1,0)                         INTPR.59    
      CALL INTER(VG ,WKINT,NLPR,INTRL,FINTR,1,1,0)                         INTPR.60    
      CALL INTER(TG ,WKINT,NLPR,INTRL,FINTR,1,0,3)                         INTPR.61    
      CALL INTER(QG ,WKINT,NLPR,INTRL,FINTR,1,0,0)                         INTPR.62    
      CALL INTER(HG ,WKINT,NLPR,INTRL,FINTR,1,0,5)                         INTPR.63    
      CALL INTER(FUG,WKINT,NLPR,INTRL,FINTR,1,0,5)                         INTPR.64    
      CALL INTER(FVG,WKINT,NLPR,INTRL,FINTR,1,0,5)                         INTPR.65    
C                                                                          INTPR.66    
      RETURN                                                               INTPR.67    
      END                                                                  INTPR.68    
C     ****************************************************************     INTPR.69    
*DECK INTER                                                                INTER.1     
      SUBROUTINE INTER(GIN,GOUT,NLOUT,INTRL,FINTR,JOW,JXUP,JXDN)           INTER.2     
C                                                                          INTER.3     
C     Interpolate vertically from input array GIN(..,NL) to output         INTER.4     
C     array GOUT(..,NLOUT), using pre-determined factors FINTR and         INTER.5     
C     levels INTRL(..,L) and INTRL(..,L+1) in input data for level         INTER.6     
C     L in output data.                                                    INTER.7     
C     If JOW=1, interpolated data is overwritten on first NLOUT levels     INTER.8     
C     of input array.                                                      INTER.9     
C     Extrapolation beyond extreme model levels controlled by namelist     INTER.10    
C     logicals LXTRP2 and LXTRP3 for LPC2 and LPC3 fields respectively.    INTER.11    
C     If switched on, JXUP and JXDN define options used.  If switched      INTER.12    
C     off, input options are overridden and values held constant beyond    INTER.13    
C     extreme model levels (equivalent to JXUP=JXDN=0).                    INTER.14    
C     Current extrapolation options are:                                   INTER.15    
C        Upward  : JXUP = 0  :  constant value above PSG(,1)               INTER.16    
C                         1  :  same as interp - linear in ln(p)           INTER.17    
C                         2  :  linear interp in p, to zero at p=0         INTER.18    
C        Downward: JXDN = 0  :  constant value below PSG(,NL)              INTER.19    
C                         1  :  same as interp - linear in ln(p)           INTER.20    
C                         2  :  interp to surface omega, const below       INTER.21    
C                         3  :  temperature: const lapse below PSG(,NL)    INTER.22    
C                         4  :  Geopotential: based on constant lapse      INTER.23    
C                         5  :  constant down to surface, zero below       INTER.24    
C     NB.  Common COMGRM must not be called as it contains INTRL.          INTER.25    
C     NB.  Common  GRIDP must not be called as it can contain GIN.         INTER.26    
C                                                                          INTER.27    
*CALL PARAM1                                                               INTER.28    
*CALL PARAM2                                                               INTER.29    
*CALL COMPRL                                                               INTER.30    
*CALL COMROG                                                               INTER.31    
*CALL LEGAU                                                                INTER.32    
      INTEGER INTRL(IGC,NLOUT)                                             INTER.33    
      REAL GIN(IGC,NL),GOUT(IGC,NLOUT),FINTR(IGC,NLOUT)                    INTER.34    
      LOGICAL LX                                                           INTER.35    
C                                                                          INTER.36    
 6900 FORMAT(/' ***ABORT IN INTER: IXUP = ',I3,' NOT ALLOWED')             ANSI2.328   
 6910 FORMAT(/' ***ABORT IN INTER: IXDN = ',I3,' NOT ALLOWED')             ANSI2.329   
C                                                                          INTER.39    
C     Set extrapolation switches.  Override input options if no extrap.    INTER.40    
C                                                                          INTER.41    
      LX=(LINTP2.AND.LXTRP2).OR.(LINTP3.AND.LXTRP3)                        INTER.42    
      IXUP=JXUP                                                            INTER.43    
      IXDN=JXDN                                                            INTER.44    
      IF (.NOT.LX) THEN                                                    INTER.45    
         IXUP=0                                                            INTER.46    
         IXDN=0                                                            INTER.47    
      ENDIF                                                                INTER.48    
C                                                                          INTER.49    
      IF (LX.AND.(IXUP.LT.0.OR.IXUP.GT.2)) THEN                            INTER.50    
         WRITE(6,6900) IXUP                                                INTER.51    
         CALL ABORT                                                        INTER.52    
      ENDIF                                                                INTER.53    
      IF (LX.AND.(IXDN.LT.0.OR.IXDN.GT.5)) THEN                            INTER.54    
         WRITE(6,6910) IXDN                                                INTER.55    
         CALL ABORT                                                        INTER.56    
      ENDIF                                                                INTER.57    
C                                                                          INTER.58    
      DO 300 IHEM=1,NHEM                                                   INTER.59    
      IOF=(IHEM-1)*MGPP                                                    INTER.60    
C                                                                          INTER.61    
C     First perform interpolation and implied extrapolation using          INTER.62    
C     default factors.                                                     INTER.63    
C                                                                          INTER.64    
      DO 5 N=1,NLOUT                                                       INTER.65    
      DO 5 I=1,MG                                                          INTER.66    
      II=I+IOF                                                             INTER.67    
      LM=INTRL(II,N)                                                       INTER.68    
    5 GOUT(II,N)=GIN(II,LM)+FINTR(II,N)*(GIN(II,LM+1)-GIN(II,LM))          INTER.69    
C                                                                          INTER.70    
C     Upward extrapolation.  Skip levels for which pressure level is       INTER.71    
C     wholly below top model level.                                        INTER.72    
C                                                                          INTER.73    
      IF (IXUP.EQ.1) GOTO 100                                              INTER.74    
      DO 90 N=1,NLOUT                                                      INTER.75    
      IF (PPR(N).GE.PSGMX(1,IHEM)) GOTO 90                                 INTER.76    
      IF (IXUP.EQ.0) THEN                                                  INTER.77    
         DO 10 I=1,MG                                                      INTER.78    
         II=I+IOF                                                          INTER.79    
         IF (PPR(N).LT.PSG(II,1)) GOUT(II,N)=GIN(II,1)                     INTER.80    
   10    CONTINUE                                                          INTER.81    
      ELSE IF (IXUP.EQ.2) THEN                                             INTER.82    
         DO 20 I=1,MG                                                      INTER.83    
         II=I+IOF                                                          INTER.84    
         IF (PPR(N).LT.PSG(II,1))  GOUT(II,N)=GIN(II,1)*PPR(N)/PSG(II,1)   INTER.85    
   20    CONTINUE                                                          INTER.86    
      ENDIF                                                                INTER.87    
   90 CONTINUE                                                             INTER.88    
C                                                                          INTER.89    
C     Downward extrapolation.  Skip levels for which pressure level is     INTER.90    
C     wholly above bottom model level.                                     INTER.91    
C                                                                          INTER.92    
  100 CONTINUE                                                             INTER.93    
      IF (IXDN.EQ.1) GOTO 200                                              INTER.94    
      DO 190 N=1,NLOUT                                                     INTER.95    
      IF (PPR(N).LE.PSGMN(NL,IHEM)) GOTO 190                               INTER.96    
      IF (IXDN.EQ.0) THEN                                                  INTER.97    
         DO 110 I=1,MG                                                     INTER.98    
         II=I+IOF                                                          INTER.99    
         IF (PPR(N).GT.PSG(II,NL)) GOUT(II,N)=GIN(II,NL)                   INTER.100   
  110    CONTINUE                                                          INTER.101   
      ELSE IF (IXDN.EQ.2) THEN                                             INTER.102   
         DO 120 I=1,MG                                                     INTER.103   
         II=I+IOF                                                          INTER.104   
         IF (PPR(N).GT.PSRF(II)) GOUT(II,N)=OMSRF(II)                      INTER.105   
         IF (PPR(N).GT.PSG(II,NL).AND.PPR(N).LE.PSRF(II))                  INTER.106   
     :      GOUT(II,N)=GIN(II,NL)+(OMSRF(II)-GIN(II,NL))*                  INTER.107   
     :                 (PPR(N)-PSG(II,NL))/(PSRF(II)-PSG(II,NL))           INTER.108   
  120    CONTINUE                                                          INTER.109   
      ELSE IF (IXDN.EQ.3) THEN                                             INTER.110   
         DO 130 I=1,MG                                                     INTER.111   
         II=I+IOF                                                          INTER.112   
         IF (PPR(N).GT.PSG(II,NL))                                         INTER.113   
     :      GOUT(II,N)=GIN(II,NL)*((PPR(N)/PSG(II,NL))**XLAPSE)            INTER.114   
  130    CONTINUE                                                          INTER.115   
      ELSE IF (IXDN.EQ.4) THEN                                             INTER.116   
         DO 140 I=1,MG                                                     INTER.117   
         II=I+IOF                                                          INTER.118   
         IF (PPR(N).GT.PSRF(II))                                           INTER.119   
     :      GOUT(II,N)=GSG(II,JL)-(TSRF(II)/XLAPSE)*                       INTER.120   
     :                            ((PPR(N)/PSRF(II))**XLAPSE-1.)           INTER.121   
         IF (PPR(N).GT.PSG(II,NL).AND.PPR(N).LE.PSRF(II))                  INTER.122   
     :      GOUT(II,N)=GIN(II,NL)+(GSG(II,JL)-GIN(II,NL))*                 INTER.123   
     :               LOG(PPR(N)/PSG(II,NL))/LOG(PSRF(II)/PSG(II,NL))       SUNMOD.92    
  140    CONTINUE                                                          INTER.125   
      ELSE IF (IXDN.EQ.5) THEN                                             INTER.126   
         DO 150 I=1,MG                                                     INTER.127   
         II=I+IOF                                                          INTER.128   
         IF (PPR(N).GT.PSRF(II)) GOUT(II,N)=0.                             INTER.129   
         IF (PPR(N).GT.PSG(II,NL).AND.PPR(N).LE.PSRF(II))                  INTER.130   
     :      GOUT(II,N)=GIN(II,NL)                                          INTER.131   
  150    CONTINUE                                                          INTER.132   
      ENDIF                                                                INTER.133   
  190 CONTINUE                                                             INTER.134   
C                                                                          INTER.135   
C     Copy to overwrite the input array if requested.                      INTER.136   
C                                                                          INTER.137   
  200 CONTINUE                                                             INTER.138   
      IF (JOW.EQ.1) THEN                                                   INTER.139   
         DO 210 N=1,NLOUT                                                  INTER.140   
         DO 210 I=1,MG                                                     INTER.141   
         II=I+IOF                                                          INTER.142   
  210    GIN(II,N)=GOUT(II,N)                                              INTER.143   
      ENDIF                                                                INTER.144   
C                                                                          INTER.145   
  300 CONTINUE                                                             INTER.146   
C                                                                          INTER.147   
      RETURN                                                               INTER.148   
      END                                                                  INTER.149   
C     ****************************************************************     INTER.150   
*DECK SFGCPR                                                               SFGCPR.1     
      SUBROUTINE SFGCPR                                                    SFGCPR.2     
C                                                                          SFGCPR.3     
C     Obtain grid point streamfunction from grid point vorticity.          SFGCPR.4     
C     Same level type and defn of gradient operator in both fields.        SFGCPR.5     
C     Involves direct spectral transform to spectral vorticity, then       SFGCPR.6     
C     inverse transform using (del)-2 operator for streamfunction.         SFGCPR.7     
C     Used when pressure level fields are required.                        SFGCPR.8     
C     NB.  Overwrites spectral vorticity with pressure-level values.       SFGCPR.9     
C                                                                          SFGCPR.10    
*CALL PARAM1                                                               SFGCPR.11    
*CALL PARAM2                                                               SFGCPR.12    
*CALL BLANK                                                                SFGCPR.13    
*CALL COMFFT                                                               SFGCPR.14    
*CALL COMIOC                                                               SFGCPR.15    
*CALL COMPRL                                                               SFGCPR.16    
*CALL GRIDP                                                                SFGCPR.17    
*CALL LEGAU                                                                SFGCPR.18    
*CALL SPECTR                                                               SFGCPR.19    
      COMPLEX GWORK(IGL,NL)                                                ANSI2.306   
C                                                                          SFGCPR.20    
C     Direct transform to obtain spectral from grid point vorticity.       SFGCPR.21    
C     Preset spectral array to zero.                                       SFGCPR.22    
C                                                                          SFGCPR.23    
      DO 10 I=1,IGB                                                        SFGCPR.24    
   10 Z(I)=CMPLX(0.,0.)                                                    SFGCPR.25    
C                                                                          SFGCPR.26    
      JL=1                                                                 SFGCPR.27    
      REWIND NCGP(2)                                                       SFGCPR.28    
      IF (JGL.EQ.1) REWIND NCLEG                                           SFGCPR.29    
      DO 50 IH=1,JG                                                        SFGCPR.30    
      IF (JGL.EQ.1) READ(NCLEG) ALP                                        SFGCPR.31    
      READ(NCGP(2)) ZG                                                     SFGCPR.32    
      IF (NTNL.EQ.0) GOTO 30                                               SFGCPR.33    
      DO 20 I=1,NTNL                                                       SFGCPR.34    
   20 CALL FFT991(ZG(1+(I-1)*NCRAY*MGPP),WORK,TRIG,IFAX                    SFGCPR.35    
     :           ,1,MGPP,MG,NCRAY,-1)                                      SFGCPR.36    
   30 CALL FFT991(ZG(1+NTNL*NCRAY*MGPP),WORK,TRIG,IFAX                     SFGCPR.37    
     :           ,1,MGPP,MG,NRSTNL,-1)                                     SFGCPR.38    
      JH=IH                                                                SFGCPR.39    
      CALL HANAL(ZG,GWORK,Z,NLPR,1)                                        ANSI2.307   
   50 JL=JL+JINC                                                           SFGCPR.41    
C                                                                          SFGCPR.42    
C     Indirect transform back to grid point space, performing the          SFGCPR.43    
C     (del)**(-2) operation to obtain streamfunction.                      SFGCPR.44    
C     Vorticity includes planetary component, so temporarily remove.       SFGCPR.45    
C     Set (m=0,n=0) coefficient to zero at all levels.                     SFGCPR.46    
C                                                                          SFGCPR.47    
      DO 60 I=1,IGB,IGA                                                    SFGCPR.48    
   60 Z(I)=Z(I)-EZ                                                         SFGCPR.49    
      IF (NHEM.EQ.2) THEN                                                  SFGCPR.50    
         DO 70 I=NWJ2+1,IGB,IGA                                            SFGCPR.51    
   70    Z(I)=0.                                                           SFGCPR.52    
      ENDIF                                                                SFGCPR.53    
C                                                                          SFGCPR.54    
      JL=1                                                                 SFGCPR.55    
      REWIND NCGP(1)                                                       SFGCPR.56    
      IF (JGL.EQ.1) REWIND NCLEG                                           SFGCPR.57    
      DO 100 IH=1,JG                                                       SFGCPR.58    
      IF (JGL.EQ.1) READ(NCLEG) ALP,DALP,RLP                               SFGCPR.59    
      CALL HEXP(Z,SFG,NLPR,5)                                              SFGCPR.60    
      IF (NTNL.EQ.0) GOTO 90                                               SFGCPR.61    
      DO 80 I=1,NTNL                                                       SFGCPR.62    
   80 CALL FFT991(SFG(1+(I-1)*NCRAY*MGPP),WORK,TRIG,IFAX                   SFGCPR.63    
     :           ,1,MGPP,MG,NCRAY,1)                                       SFGCPR.64    
   90 CALL FFT991(SFG(1+NTNL*NCRAY*MGPP),WORK,TRIG,IFAX                    SFGCPR.65    
     :           ,1,MGPP,MG,NRSTNL,1)                                      SFGCPR.66    
      WRITE(NCGP(1)) SFG                                                   SFGCPR.67    
  100 JL=JL+JINC                                                           SFGCPR.68    
C                                                                          SFGCPR.69    
      DO 110 I=1,IGB,IGA                                                   SFGCPR.70    
  110 Z(I)=Z(I)+EZ                                                         SFGCPR.71    
C                                                                          SFGCPR.72    
      RETURN                                                               SFGCPR.73    
      END                                                                  SFGCPR.74    
C     ****************************************************************     SFGCPR.75    
*DECK FLUX                                                                 FLUX.1     
      SUBROUTINE FLUX                                                      FLUX.2     
C                                                                          FLUX.3     
C     Calculate zonally averaged fields at current analysis time and       FLUX.4     
C     store in common ZONAV.  Increment their time averages in common      FLUX.5     
C     TAV.  Uses full 3-dimensional fields from scratch files.             FLUX.6     
C                                                                          FLUX.7     
C     Averages are taken on isobaric levels, so interpolate from model     FLUX.8     
C     levels if necessary.  It is assumed there are NL isobaric levels     FLUX.9     
C     with p(l) = P0*sigma(l).  Program should have aborted in INIPLV      FLUX.10    
C     or switched off these diagnostics if any other pressure levels       FLUX.11    
C     were requested.                                                      FLUX.12    
C                                                                          FLUX.13    
C     NB.  FLUX can be called using data on model levels,                  SUNMOD.58    
C         (LINTP2=.FALSE., LINTP3=.FALSE.)                                 SUNMOD.59    
c      but then several fields are invalid since their                     SUNMOD.60    
C     calculation assumes isobaric data: potential temperature, relative   FLUX.16    
C     humidity and derived dynamical fields.                               FLUX.17    
C     NB.  Calculations for several fields assume isobaric levels are      FLUX.18    
C     P0*sigma by using the fact that non-dimensional pressure is then     FLUX.19    
C     just sigma.                                                          FLUX.20    
C     NB.  The reference pressure for adiabatic processes is assumed       FLUX.21    
C     to be the non-dimensionalising P0.                                   FLUX.22    
C                                                                          FLUX.23    
C     NB.  Following zonal arrays used as workspace:                       FLUX.24    
C          DUMNZ, DUMCN, DUMCK, DUMBP.                                     FLUX.25    
C                                                                          FLUX.26    
*CALL PARAM1                                                               FLUX.27    
*CALL PARAM2                                                               FLUX.28    
*CALL BATS                                                                 FLUX.29    
*CALL BLANK                                                                FLUX.30    
*CALL COMGEN                                                               FLUX.31    
*CALL COMIOC                                                               FLUX.32    
*CALL COMPRL                                                               FLUX.33    
*CALL COMROG                                                               FLUX.34    
*CALL GRIDP                                                                FLUX.35    
*CALL LEGAU                                                                FLUX.36    
*CALL PHYS                                                                 FLUX.37    
*CALL TAV                                                                  FLUX.38    
*CALL ZONAV                                                                FLUX.39    
      REAL DDZ(IDDZ),DDZT(IDDZ)                                            FLUX.40    
     :    ,FUBR(JGG,NL),FVBR(JGG,NL),TEMPZ(JGG,NL)                         FLUX.41    
     :    ,ZTEM(JGG,NL),ZTEMY(JGG,NL),ZTEMP(JGG,NL)                        XDTEM3.4     
     :    ,RHG(IGD),TEMP(NL)                                               FLUX.42    
      EQUIVALENCE (DDZ(1),UBR(1,1)),(DDZT(1),UBT(1,1))                     FLUX.43    
     :           ,(RHG(1),EPVG(1))                                         FLUX.44    
     :           ,(FUBR(1,1),DUMCN(1,1)),(FVBR(1,1),DUMCK(1,1))            FLUX.45    
     :           ,(TEMPZ(1,1),DUMNZ(1,1))                                  FLUX.46    
C                                                                          FLUX.47    
C     Rewind scratch files.                                                FLUX.48    
C                                                                          FLUX.49    
      IF (LROG.AND.JGL.EQ.1) REWIND NCROGG                                 FLUX.50    
      DO 10 I=1,NGP                                                        FLUX.51    
   10 REWIND NCGP(I)                                                       FLUX.52    
C                                                                          FLUX.53    
C     Vertical derivatives of restoration temperatures.                    FLUX.54    
C                                                                          FLUX.55    
      CALL DLSGCR(JGG,TBRES,RGG,DUMBP,JGG,NL)                              FLUX.56    
C                                                                          FLUX.57    
C     ----------------------------------------------------------------     FLUX.58    
C     Main loop over latitude.  First read data.                           FLUX.59    
C                                                                          FLUX.60    
      JL=1                                                                 FLUX.61    
      DO 90 IH=1,JG                                                        FLUX.62    
      JH=IH                                                                FLUX.63    
C                                                                          FLUX.64    
      IF (LROG.AND.JGL.EQ.1) READ(NCROGG) GSG                              FLUX.65    
      READ(NCGP( 3)) DG                                                    FLUX.66    
      READ(NCGP( 4)) OMG                                                   FLUX.67    
      READ(NCGP( 5)) UG                                                    FLUX.68    
      READ(NCGP( 6)) VG                                                    FLUX.69    
      READ(NCGP( 7)) TG                                                    FLUX.70    
      READ(NCGP( 9)) QG                                                    FLUX.71    
      READ(NCGP(10)) HG                                                    FLUX.72    
      READ(NCGP(11)) PLG,PMG,PJG                                           FLUX.73    
      READ(NCGP(13)) FUG                                                   FLUX.74    
      READ(NCGP(14)) FVG                                                   FLUX.75    
      RMGSEC=RMG*SQRT(SECSQ(IH))                                           FLUX.76    
      RMGSSQ=RMG*SECSQ(IH)                                                 FLUX.77    
C                                                                          FLUX.78    
C     Interpolate to isobaric levels if required.                          FLUX.79    
C                                                                          FLUX.80    
      IF (LINTP3.AND.(.NOT.LINTP2)) THEN                                   FLUX.81    
         CALL PSGCR                                                        FLUX.82    
         CALL SRFCR                                                        FLUX.83    
         CALL INTPR                                                        FLUX.84    
      ENDIF                                                                FLUX.85    
C                                                                          FLUX.86    
      DO 80 IHEM=1,NHEM                                                    FLUX.87    
      IOF=(IHEM-1)*MGPP                                                    FLUX.88    
      IK=(3-2*IHEM)*IH+(JGG+1)*(IHEM-1)                                    FLUX.89    
C                                                                          FLUX.90    
C     Calculate potential temperature and relative humidity.               FLUX.91    
C     Use formula from SGCM, PDN=BGCM5,ID=UPLIB,ED=5, for Qs(T,p).         FLUX.92    
C                                                                          FLUX.93    
      DO 20 L=1,NL                                                         FLUX.94    
      K=(L-1)*IGC+IOF                                                      FLUX.95    
      DO 20 I=1,MG                                                         FLUX.96    
      K=K+1                                                                FLUX.97    
      THG(K)=TG(K)*SIGMAK(L)                                               FLUX.98    
      QS=ESCONA*EXP(-ESCONB/TG(K))/SIGMA(L)                                FLUX.99    
      RHG(K)=QG(K)/QS                                                      FLUX.100   
   20 CONTINUE                                                             FLUX.101   
C                                                                          FLUX.102   
C     Form zonal averages of basic fields and variances.                   FLUX.103   
C     Arrays in ZONAV have point nearest north pole stored first           FLUX.104   
C     and, for NHEM=2, point nearest south pole stored last.               FLUX.105   
C                                                                          FLUX.106   
      SFM=0.                                                               FLUX.107   
      DO 30 L=1,NL                                                         FLUX.108   
      I=(L-1)*IGC+IOF+1                                                    FLUX.109   
      UBR(IK,L) =SSUM(MG,UG(I) ,1)*RMGSEC                                  FLUX.110   
      VBR(IK,L) =SSUM(MG,VG(I) ,1)*RMGSEC                                  FLUX.111   
      WBR(IK,L) =SSUM(MG,OMG(I),1)*RMG                                     FLUX.112   
      TBR(IK,L) =SSUM(MG,TG(I) ,1)*RMG                                     FLUX.113   
      QBR(IK,L) =SSUM(MG,QG(I) ,1)*RMG                                     FLUX.114   
      HBR(IK,L) =SSUM(MG,HG(I) ,1)*RMG                                     FLUX.115   
      RHBR(IK,L)=SSUM(MG,RHG(I),1)*RMG                                     FLUX.116   
      THBR(IK,L)=SSUM(MG,THG(I),1)*RMG                                     FLUX.117   
      FUBR(IK,L)=SSUM(MG,FUG(I),1)*RMGSEC                                  FLUX.118   
      FVBR(IK,L)=SSUM(MG,FVG(I),1)*RMGSEC                                  FLUX.119   
      UVBR(IK,L)=SDOT(MG,UG(I),1,VG(I) ,1)*RMGSSQ                          FLUX.120   
      UWBR(IK,L)=SDOT(MG,UG(I),1,OMG(I),1)*RMGSEC                          FLUX.121   
      VTBR(IK,L)=SDOT(MG,VG(I),1,TG(I) ,1)*RMGSEC                          FLUX.122   
      WTBR(IK,L)=SDOT(MG,TG(I),1,OMG(I),1)*RMG                             FLUX.123   
      VQBR(IK,L)=SDOT(MG,VG(I),1,QG(I) ,1)*RMGSEC                          FLUX.124   
      WQBR(IK,L)=SDOT(MG,QG(I),1,OMG(I),1)*RMG                             FLUX.125   
      UUBR(IK,L)=SDOT(MG,UG(I),1,UG(I) ,1)*RMGSSQ                          FLUX.126   
      VVBR(IK,L)=SDOT(MG,VG(I),1,VG(I) ,1)*RMGSSQ                          FLUX.127   
      TTBR(IK,L)=SDOT(MG,TG(I),1,TG(I) ,1)*RMG                             FLUX.128   
      HTBR(IK,L)=SDOT(MG,HG(I),1,TG(I) ,1)*RMG                             FLUX.129   
      VWBR(IK,L)=SDOT(MG,VG(I),1,OMG(I),1)*RMGSEC                          FLUX.130   
      FUER(IK,L)=(SDOT(MG,FUG(I),1,UG(I),1)                                FLUX.131   
     :           +SDOT(MG,FVG(I),1,VG(I),1))*RMGSSQ                        FLUX.132   
      SF=SFM+DSIGMA(L)*VBR(IK,L)*CS(IH)                                    FLUX.133   
      SFMCR(IK,L)=.5*(SF+SFM)                                              FLUX.134   
      SFM=SF                                                               FLUX.135   
   30 CONTINUE                                                             FLUX.136   
C                                                                          FLUX.137   
      BP=SSUM(MG,PLG(IOF+1),1)*RMG-1.                                      FLUX.138   
      DO 40 L=1,NL                                                         FLUX.139   
      TMTRES(IK,L)=TBR(IK,L)-(TBRES(IK,L)-BP*DUMBP(IK,L))                  FLUX.140   
   40 CONTINUE                                                             FLUX.141   
C                                                                          FLUX.142   
   80 CONTINUE                                                             FLUX.143   
C                                                                          FLUX.144   
   90 JL=JL+JINC                                                           FLUX.145   
C                                                                          FLUX.146   
C     ----------------------------------------------------------------     FLUX.147   
C     End of main latitude loop.                                           FLUX.148   
C                                                                          FLUX.149   
C     Calculate layer mean and global mean values of omega,                FLUX.150   
C     temperature and diabatic heating.                                    FLUX.151   
C                                                                          FLUX.152   
      WMNN=GAV(WBR,GWT,JGG,DSIGMA,NL,WMN)                                  FLUX.153   
      TMNN=GAV(TBR,GWT,JGG,DSIGMA,NL,TMN)                                  FLUX.154   
      HMNN=GAV(HBR,GWT,JGG,DSIGMA,NL,HMN)                                  FLUX.155   
C                                                                          FLUX.156   
C     Separate zonal and eddy variances, calculate other derived fields.   FLUX.157   
C     NB.  To prevent contamination of energy conversions, remove          FLUX.158   
C     isobaric means of omega, temperature and heating from mean heat      FLUX.159   
C     flux and heating arrays (VBTBR, WBTBR, HBTBR).                       FLUX.160   
C     NB.  Layer mean omega is theoretically zero on all global isobaric   FLUX.161   
C     surfaces above orography but numerical estimates are generally non   FLUX.162   
C     zero.  It does not enter the global energetics so, in order not to   FLUX.163   
C     contaminate the results, is removed at all levels irrespective of    FLUX.164   
C     whether above or below orography, model-level or isobaric. It is     FLUX.165   
C     NOT removed from the omega array itself.  If this is done, it must   FLUX.166   
C     be AFTER separating the zonal and eddy variances, or the vertical    FLUX.167   
C     eddy fluxes will be contaminated.                                    FLUX.168   
C                                                                          FLUX.169   
      DO 100 L=1,NL                                                        FLUX.170   
      DO 100 J=1,JGG                                                       FLUX.171   
      UVBR(J,L)=UVBR(J,L)-UBR(J,L)*VBR(J,L)                                FLUX.172   
      UWBR(J,L)=UWBR(J,L)-UBR(J,L)*WBR(J,L)                                FLUX.173   
      VTBR(J,L)=VTBR(J,L)-VBR(J,L)*TBR(J,L)                                FLUX.174   
      WTBR(J,L)=WTBR(J,L)-WBR(J,L)*TBR(J,L)                                FLUX.175   
      VQBR(J,L)=VQBR(J,L)-VBR(J,L)*QBR(J,L)                                FLUX.176   
      WQBR(J,L)=WQBR(J,L)-WBR(J,L)*QBR(J,L)                                FLUX.177   
      UUBR(J,L)=UUBR(J,L)-UBR(J,L)*UBR(J,L)                                FLUX.178   
      VVBR(J,L)=VVBR(J,L)-VBR(J,L)*VBR(J,L)                                FLUX.179   
      TTBR(J,L)=TTBR(J,L)-TBR(J,L)*TBR(J,L)                                FLUX.180   
      HTBR(J,L)=HTBR(J,L)-HBR(J,L)*TBR(J,L)                                FLUX.181   
      VWBR(J,L)=VWBR(J,L)-VBR(J,L)*WBR(J,L)                                FLUX.182   
      AKZ (J,L)=.5*(UBR(J,L)*UBR(J,L)+VBR(J,L)*VBR(J,L))                   FLUX.183   
      AKE (J,L)=.5*(UUBR(J,L)+VVBR(J,L))                                   FLUX.184   
      FUZR(J,L)=FUBR(J,L)*UBR(J,L)+FVBR(J,L)*VBR(J,L)                      FLUX.185   
      FUER(J,L)=FUER(J,L)-FUZR(J,L)                                        FLUX.186   
      VBTBR(J,L)=VBR(J,L)*(TBR(J,L)-TMN(L))                                FLUX.187   
      WBTBR(J,L)=(WBR(J,L)-WMN(L))*(TBR(J,L)-TMN(L))                       FLUX.188   
      HBTBR(J,L)=(HBR(J,L)-HMN(L))*(TBR(J,L)-TMN(L))                       FLUX.189   
  100 CONTINUE                                                             FLUX.190   
C                                                                          FLUX.191   
C     Derive remaining zonally averaged quantities.                        FLUX.192   
C                                                                          FLUX.193   
C     Calculate terms involving first meridional derivative.               FLUX.194   
C                                                                          FLUX.195   
      DO 110 L=1,NL                                                        FLUX.196   
      DO 110 J=2,JGGM                                                      FLUX.197   
      JM=J-1                                                               FLUX.198   
      JP=J+1                                                               FLUX.199   
      DM=1./(SI(JP)-SI(JM))                                                FLUX.200   
      ABSV(J,L)=SI(J)+SI(J)-(UBR(JP,L)*CS(JP)-UBR(JM,L)*CS(JM))*DM         FLUX.201   
      DUBDMU(J,L)=(UBR(JP,L)/CS(JP)-UBR(JM,L)/CS(JM))*DM                   FLUX.202   
      DVBDMU(J,L)=(VBR(JP,L)/CS(JP)-VBR(JM,L)/CS(JM))*DM                   FLUX.203   
      DTBDMU(J,L)=(TBR(JP,L)-TBR(JM,L))*DM                                 FLUX.204   
  110 CONTINUE                                                             FLUX.205   
C                                                                          FLUX.206   
C     Extrapolate to northern- and southernmost Gaussian latitudes.        FLUX.207   
C                                                                          FLUX.208   
      DO 120 L=1,NL                                                        FLUX.209   
      ABSV(  1,L)  =EXN1*ABSV(   2,L)  -EXN2*ABSV(    3,L)                 FLUX.210   
      ABSV(JGG,L)  =EXS1*ABSV(JGGM,L)  -EXS2*ABSV(JGGM2,L)                 FLUX.211   
      DUBDMU(  1,L)=EXN1*DUBDMU(   2,L)-EXN2*DUBDMU(    3,L)               FLUX.212   
      DUBDMU(JGG,L)=EXS1*DUBDMU(JGGM,L)-EXS2*DUBDMU(JGGM2,L)               FLUX.213   
      DVBDMU(  1,L)=EXN1*DVBDMU(   2,L)-EXN2*DVBDMU(    3,L)               FLUX.214   
      DVBDMU(JGG,L)=EXS1*DVBDMU(JGGM,L)-EXS2*DVBDMU(JGGM2,L)               FLUX.215   
      DTBDMU(  1,L)=EXN1*DTBDMU(   2,L)-EXN2*DTBDMU(    3,L)               FLUX.216   
      DTBDMU(JGG,L)=EXS1*DTBDMU(JGGM,L)-EXS2*DTBDMU(JGGM2,L)               FLUX.217   
  120 CONTINUE                                                             FLUX.218   
C                                                                          FLUX.219   
C     Calculate terms involving first vertical derivative.                 FLUX.220   
C                                                                          FLUX.221   
      CALL DLSGCR(JGG,UBR,RGG,UBRP,JGG,NL)                                 FLUX.222   
      CALL DLSGCR(JGG,VBR,RGG,VBRP,JGG,NL)                                 FLUX.223   
      CALL DLSGCR(JGG,TBR,RGG,STBP,JGG,NL)                                 FLUX.224   
      AG=1.                                                                FLUX.225   
      DO 130 L=1,NL                                                        FLUX.226   
      DO 130 J=1,JGG                                                       FLUX.227   
      UBRP(J,L)=UBRP(J,L)/SIGMA(L)                                         FLUX.228   
      VBRP(J,L)=VBRP(J,L)/SIGMA(L)                                         FLUX.229   
      THBP(J,L)=(STBP(J,L)-AKAP*TBR(J,L))/SIGMA(L)                         FLUX.230   
      ENSQ(J,L)=-THBP(J,L)*SIGMA(L)/(TBR(J,L)*TBR(J,L))                    FLUX.231   
      TEMPZ(J,L)=UBRP(J,L)*SIGMA(L)/THBP(J,L)                              FLUX.232   
      EPFH(J,L)=CSSQ(J)*(-UVBR(J,L)+AG*UBRP(J,L)*VTBR(J,L)/THBP(J,L))      FLUX.233   
      EPFV(J,L)=CSSQ(J)*(AG*UWBR(J,L)-ABSV(J,L)*VTBR(J,L)/THBP(J,L))       FLUX.234   
      ZTEM(J,L)=VTBR(J,L)/THBP(J,L)                                        XDTEM3.5     
      TEMSFBR(J,L)=SFMCR(J,L)-CS(J)*ZTEM(J,L)                              XDTEM3.6     
  130 CONTINUE                                                             FLUX.235   
C                                                                          FLUX.236   
C     Calculate terms involving second meridional derivative.              FLUX.237   
C                                                                          FLUX.238   
      DO 140 L=1,NL                                                        FLUX.239   
      DO 140 J=2,JGGM                                                      FLUX.240   
      JM=J-1                                                               FLUX.241   
      JP=J+1                                                               FLUX.242   
      DM=1.0/(SI(JP)-SI(JM))                                               FLUX.243   
      QY(J,L)=(ABSV(JP,L)-ABSV(JM,L))*DM                                   FLUX.244   
      EPDH(J,L)=CS(J)*(EPFH(JP,L)-EPFH(JM,L))*DM                           FLUX.245   
      ZTEMY(J,L)=(ZTEM(JP,L)*CS(JP)-ZTEM(JM,L)*CS(JM))*DM                  XDTEM3.7     
  140 CONTINUE                                                             FLUX.246   
C                                                                          FLUX.247   
C     Extrapolate to northern- and southernmost Gaussian latitudes.        FLUX.248   
C                                                                          FLUX.249   
      DO 150 L=1,NL                                                        FLUX.250   
      QY(  1,L)  =EXN1*QY(   2,L)  -EXN2*QY(    3,L)                       FLUX.251   
      QY(JGG,L)  =EXS1*QY(JGGM,L)  -EXS2*QY(JGGM2,L)                       FLUX.252   
      EPDH(  1,L)=EXN1*EPDH(   2,L)-EXN2*EPDH(    3,L)                     FLUX.253   
      EPDH(JGG,L)=EXS1*EPDH(JGGM,L)-EXS2*EPDH(JGGM2,L)                     FLUX.254   
      ZTEMY(  1,L)=EXN1*ZTEMY(   2,L)-EXN2*ZTEMY(    3,L)                  XDTEM3.8     
      ZTEMY(JGG,L)=EXS1*ZTEMY(JGGM,L)-EXS2*ZTEMY(JGGM2,L)                  XDTEM3.9     
  150 CONTINUE                                                             FLUX.255   
C                                                                          FLUX.256   
C     Calculate terms involving second vertical derivatives.               FLUX.257   
C     Form total E-P flux divergence.                                      FLUX.258   
C                                                                          FLUX.259   
      CALL DLSGCR(JGG,TEMPZ,RGG,DUMBP,JGG,NL)                              FLUX.260   
      CALL DLSGCR(JGG,EPFV,RGG,EPDV,JGG,NL)                                FLUX.261   
      CALL DLSGCR(JGG,ZTEM,RGG,ZTEMP,JGG,NL)                               XDTEM3.10    
      DO 160 L=1,NL                                                        FLUX.262   
      DO 160 J=1,JGG                                                       FLUX.263   
      QY(J,L)=QY(J,L)*CS(J)+DUMBP(J,L)*4.*SISQ(J)/SIGMA(L)                 FLUX.264   
      EPDV(J,L)=-EPDV(J,L)/SIGMA(L)                                        FLUX.265   
      EPDT(J,L)=EPDH(J,L)+EPDV(J,L)                                        FLUX.266   
      TEMVBR(J,L)=VBR(J,L)-ZTEMP(J,L)/SIGMA(L)                             XDTEM3.11    
      TEMWBR(J,L)=WBR(J,L)+ZTEMY(J,L)                                      XDTEM3.12    
  160 CONTINUE                                                             FLUX.267   
C                                                                          FLUX.268   
C     Calculate maximum permitted wavenumber for waves with specified      FLUX.269   
C     eastward phase speed.                                                FLUX.270   
C                                                                          FLUX.271   
      DO 170 J=1,JGG                                                       FLUX.272   
      DO 170 L=1,NL                                                        FLUX.273   
      UMC=UBR(J,L)/CS(J)-CPHASE                                            FLUX.274   
      IF (UMC.EQ.0.) THEN                                                  FLUX.275   
         A=1.E4                                                            FLUX.276   
      ELSE                                                                 FLUX.277   
         A=QY(J,L)*CS(J)/UMC                                               FLUX.278   
         IF (A.LT.0.) A=1.E4                                               FLUX.279   
      ENDIF                                                                FLUX.280   
      TPWN(J,L)=SQRT(A)                                                    FLUX.281   
  170 CONTINUE                                                             FLUX.282   
C                                                                          FLUX.283   
C     Set up factor for time-averaging.                                    FLUX.284   
C     Increment time averages of zonally averaged arrays.                  FLUX.285   
C                                                                          FLUX.286   
      IF (LTAV) THEN                                                       FLUX.287   
         FD=FTAV                                                           FLUX.288   
         IF (KOUNT.EQ.KSTART.OR.KOUNT.EQ.KEND) FD=.5*FD                    FLUX.289   
         DO 180 I=1,IDDZ                                                   FLUX.290   
  180    DDZT(I)=DDZT(I)+FD*DDZ(I)                                         FLUX.291   
      ENDIF                                                                FLUX.292   
C                                                                          FLUX.293   
C     Rewind scratch files.                                                FLUX.294   
C                                                                          FLUX.295   
      IF (LROG.AND.JGL.EQ.1) REWIND NCROGG                                 FLUX.296   
      DO 190 I=1,NGP                                                       FLUX.297   
  190 REWIND NCGP(I)                                                       FLUX.298   
C                                                                          FLUX.299   
      RETURN                                                               FLUX.300   
      END                                                                  FLUX.301   
C     ****************************************************************     FLUX.302   
*DECK GAV                                                                  GAV.1     
      FUNCTION GAV(F,GWT,JM,G,LM,TEMP)                                     GAV.2     
C                                                                          GAV.3     
C     Calculate global average from zonal mean array of field in           GAV.4     
C     isobaric co-ordinates.  Makes uniform surface pressure               GAV.5     
C     approximation: ie all columns given equal weighting.                 GAV.6     
C     Type of average depends on layer mean values in 4th argument         GAV.7     
C     G(LM) (see calls in GDIAG):                                          GAV.8     
C          G = DSIGMA                  :  global mass average of F.        GAV.9     
C          G = DSRSI  = DSIGMA/SIGMA   :  global mass average of F/p.      GAV.10    
C          G = SDSRSI = STAB*DSRSI     :  stability weighted average.      GAV.11    
C                                                                          GAV.12    
C     Input arguments:                                                     GAV.13    
C          F    :  real array of zonal means to be averaged.               GAV.14    
C          GWT  :  real array of Gaussian weights, suitably normalised     GAV.15    
C                  for hemispheric or global averaging.                    GAV.16    
C          JM   :  number of Gaussian latitudes, hemispheric or global     GAV.17    
C                  as in model run.                                        GAV.18    
C          G    :  real array of layer means defining type of averaging.   GAV.19    
C          LM   :  number of levels.                                       GAV.20    
C          TEMP :  real workspace array.                                   GAV.21    
C     On output GAV contains global average and TEMP contains layer        GAV.22    
C     means.  Other arguments unchanged.                                   GAV.23    
C                                                                          GAV.24    
      REAL F(JM,LM),G(LM),TEMP(LM),GWT(JM)                                 GAV.25    
C                                                                          GAV.26    
      DO 10 L=1,LM                                                         GAV.27    
      TEMP(L)=SDOT(JM,GWT(1),1,F(1,L),1)                                   GAV.28    
  10  CONTINUE                                                             GAV.29    
      GAV=SDOT(LM,TEMP(1),1,G(1),1)                                        GAV.30    
C                                                                          GAV.31    
      RETURN                                                               GAV.32    
      END                                                                  GAV.33    
C     ****************************************************************     GAV.34    
*DECK GDIAG                                                                GDIAG.1     
      SUBROUTINE GDIAG                                                     GDIAG.2     
C                                                                          GDIAG.3     
C     Perform global energetics analysis using Entropic Potential          GDIAG.4     
C     Energy (EPE) and Kinetic Energy (KE).  The scheme is defined in      GDIAG.5     
C     Blackburn (1983, PhD thesis, University of Reading) and is a         GDIAG.6     
C     modified version of that defined by Pearce (1978, QJRMS, 104,        GDIAG.7     
C     pp737-755).                                                          GDIAG.8     
C                                                                          GDIAG.9     
C                  l------l                l------l                        GDIAG.10    
C          --Gz----l  NZ  l------Czz-------l  KZ  l----Dz--                GDIAG.11    
C                  l------l                l------l                        GDIAG.12    
C                     l    \              /   l                            GDIAG.13    
C                     l    Cnsz        Csz    l                            GDIAG.14    
C                     l       \        /      l                            GDIAG.15    
C                    Cnze      l------l       l                            GDIAG.16    
C          --Gs-------l--------l  NS  l     Ckze                           GDIAG.17    
C                     l        l------l       l                            GDIAG.18    
C                     l       /        \      l                            GDIAG.19    
C                     l    Cnse        Cse    l                            GDIAG.20    
C                     l    /              \   l                            GDIAG.21    
C                  l------l                l------l                        GDIAG.22    
C          --Ge----l  NE  l------Cee-------l  KE  l----De--                GDIAG.23    
C                  l------l                l------l                        GDIAG.24    
C                                                                          GDIAG.25    
C     Extra terms calculated are:                                          GDIAG.26    
C          TE = NE  + KE     total eddy energy,                            GDIAG.27    
C          Cz = Czz + Csz    total conversion from EPE to KZ,              GDIAG.28    
C          Ce = Cee + Cse    total conversion from EPE to KE.              GDIAG.29    
C     Energies are given in Joules/m2 and conversions in Watts/m2.         GDIAG.30    
C     For values in J/kg and W/kg, divide by the unit area mass, P0/GA.    GDIAG.31    
C     All global integrals are over mass and give equal weighting to       GDIAG.32    
C     all columns by integrating from p=0 to p=P0.                         GDIAG.33    
C                                                                          GDIAG.34    
C     This routine is called at each analysis time to compute the          GDIAG.35    
C     instantaneous energies and conversions and to increment the          GDIAG.36    
C     time averages.  The time series is built up on channel NCGEN and     GDIAG.37    
C     is read at the end of the run when GDIAG is called with KOUNT<0.     GDIAG.38    
C     The time series and averages are then printed and optionally         GDIAG.39    
C     written to channel NCPLOT(1) for plotting in a subsequent program.   GDIAG.40    
C                                                                          GDIAG.41    
*CALL PARAM1                                                               GDIAG.42    
*CALL PARAM2                                                               GDIAG.43    
*CALL BATS                                                                 GDIAG.44    
*CALL BLANK                                                                GDIAG.45    
*CALL COMGEN                                                               GDIAG.46    
*CALL COMIOC                                                               GDIAG.47    
*CALL LEGAU                                                                GDIAG.48    
*CALL OUTCON                                                               GDIAG.49    
*CALL SERIES                                                               GDIAG.50    
*CALL ZONAV                                                                GDIAG.51    
      REAL STAB(NL),GAMDS(NL),DSRSI(NL),SDSRSI(NL),TEMP(NL)                GDIAG.52    
     ;    ,TMSQ(NL),HMTM(NL),WTMN(NL)                                      GDIAG.53    
      REAL TEQV(NTERM5),SEQV(NTERM5)                                       GDIAG.54    
      EQUIVALENCE (TEQV(1),TNS),(SEQV(1),SNS)                              GDIAG.55    
      CHARACTER IYLAB*30,IYLABA*30,IXLAB*30,ICAN(6)*3,ICANA(15)*3          GENPLT1.3     
      SAVE IYLAB,IYLABA,ICAN,ICANA                                         GENPLT1.4     
C                                                                          GDIAG.59    
      DATA IYLAB /'              ENERGIES*.'/                              GDIAG.60    
      DATA IYLABA/'          ENERGY CONVERSIONS*.'/                        GDIAG.61    
      DATA ICAN  /' NS',' NZ',' NE',' KZ',' KE','   '/                     GDIAG.65    
     :    ,ICANA /' CZ',' CE','NZE','KZE','NSZ','NSE'                      GDIAG.66    
     :           ,' GS',' GZ',' GE',' DZ',' DE'                            GDIAG.67    
     :           ,'IGZ','IGE','IDZ','IDE'/                                 GDIAG.68    
C                                                                          GDIAG.69    
 6000 FORMAT(' GLOBAL ENERGETICS AT DAY ',F10.2)                           BUGS5.29    
 6010 FORMAT(' TIME AVERAGE GLOBAL DIAGNOSTICS')                           GDIAG.71    
 6020 FORMAT(' GLOBAL MEANS: TEMP  OMEGA  HEATING  STABILITY =',4F12.5)    GDIAG.72    
 6030 FORMAT(' ***GDIAG : TIME SERIES OF GLOBAL ENERGETICS ON PLOT FILE'   GDIAG.73    
     :      ,' STOPS AT DAY',F10.2)                                        GDIAG.74    
 6040 FORMAT('# ENERGETICS TIME SERIES RUNS FROM DAY ',F10.2               GENPLT1.5     
     :      ,' TO DAY ',F10.2)                                             GENPLT1.6     
 6100 FORMAT(1P,'     NS=',E11.4,'     NZ=',E11.4                          GDIAG.77    
     :         ,'     NE=',E11.4,'     KZ=',E11.4                          GDIAG.78    
     :         ,'     KE=',E11.4,'     TE=',E11.4,'    J/M2')              GDIAG.79    
 6110 FORMAT(1P,'   CNZE=',E11.4,'    CZZ=',E11.4,'    CSZ=',E11.4         GDIAG.80    
     :         ,'   CNSZ=',E11.4,'     CZ=',E11.4,'    W/M2'               GDIAG.81    
     :         /'   CKZE=',E11.4,'    CEE=',E11.4,'    CSE=',E11.4         GDIAG.82    
     :         ,'   CNSE=',E11.4,'     CE=',E11.4,'    W/M2')              GDIAG.83    
 6120 FORMAT(1P,'     GS=',E11.4,'     GZ=',E11.4,'     GE=',E11.4         GDIAG.84    
     :         ,'     DZ=',E11.4,'     DE=',E11.4,'    W/M2')              GDIAG.85    
 6130 FORMAT(1P,'        ',  11X,'    IGZ=',E11.4,'    IGE=',E11.4         GDIAG.86    
     :         ,'    IDZ=',E11.4,'    IDE=',E11.4,'    W/M2')              GDIAG.87    
 6140 FORMAT(1P,'    RNS=',E11.4,'    RNZ=',E11.4,'    RKZ=',E11.4         GDIAG.88    
     :         ,'    DRZ=',E11.4,'    DRE=',E11.4,'    W/M2')              GDIAG.89    
C                                                                          GDIAG.90    
      IF (KOUNT.LT.0) GOTO 100                                             GDIAG.91    
C                                                                          GDIAG.92    
C     ----------------------------------------------------------------     GDIAG.93    
C                                                                          GDIAG.94    
C     Calculate global averages for one analysis time                      GDIAG.95    
C     and increment time averages.                                         GDIAG.96    
C                                                                          GDIAG.97    
      IF (KOUNT.EQ.KSTART) THEN                                            GDIAG.98    
         NPTS5=0                                                           GDIAG.99    
         REWIND NCGEN                                                      GDIAG.100   
         IF (LTAV) THEN                                                    GDIAG.101   
            DO 10 N=1,NTERM5                                               GDIAG.102   
   10       SEQV(N)=0.                                                     GDIAG.103   
         ENDIF                                                             GDIAG.104   
      ENDIF                                                                GDIAG.105   
C                                                                          GDIAG.106   
C     Zonal and isobaric means required for global energetics.             GDIAG.107   
C                                                                          GDIAG.108   
      CALL DLSGCR(1,TMN,RGG,STAB,1,NL)                                     GDIAG.109   
      GAML=1./(AKAP*TMNN)                                                  GDIAG.110   
      DO 20 L=1,NL                                                         GDIAG.111   
      STAB(L)=GAML*STAB(L)                                                 GDIAG.112   
      GAMDS(L)=GAML*DSIGMA(L)                                              GDIAG.113   
      DSRSI(L)=DSIGMA(L)/SIGMA(L)                                          GDIAG.114   
      SDSRSI(L)=STAB(L)*DSRSI(L)                                           GDIAG.115   
      TMSQ(L)=(TMN(L)-TMNN)*(TMN(L)-TMNN)                                  GDIAG.116   
      HMTM(L)=(HMN(L)-HMNN)*(TMN(L)-TMNN)                                  GDIAG.117   
   20 CONTINUE                                                             GDIAG.118   
      STMNN=SDOT(NL,STAB(1),1,DSIGMA(1),1)                                 GDIAG.119   
      DO 30 L=1,NL                                                         GDIAG.120   
      WTMN(L)=SDOT(JGG,WTBR(1,L),1,GWT(1),1)                               GDIAG.121   
      DO 30 J=1,JGG                                                        GDIAG.122   
      DUMNZ(J,L)=(TBR(J,L)-TMN(L))*(TBR(J,L)-TMN(L))                       GDIAG.123   
      DUMCN(J,L)=VTBR(J,L)*DTBDMU(J,L)*GAML*CS(J)                          GDIAG.124   
     :          +(WTBR(J,L)-WTMN(L))*(STBP(J,L)*GAML-STAB(L))/SIGMA(L)     GDIAG.125   
      DUMCK(J,L)=CSSQ(J)*(UVBR(J,L)*DUBDMU(J,L)+VVBR(J,L)*DVBDMU(J,L))     GDIAG.126   
     :          +UWBR(J,L)*UBRP(J,L)+VWBR(J,L)*VBRP(J,L)                   GDIAG.127   
     :          -VBR(J,L)*AKE(J,L)*2.*SI(J)/CS(J)                          GDIAG.128   
   30 CONTINUE                                                             GDIAG.129   
C                                                                          GDIAG.130   
C     Calculate globally averaged energetics values.                       GDIAG.131   
C                                                                          GDIAG.132   
      EFAC=CG*P0/GA                                                        GDIAG.133   
      CFAC=EFAC*WW                                                         GDIAG.134   
      TNZ= GAV(DUMNZ,GWT,JGG,GAMDS ,NL,TEMP)*EFAC*.5                       GDIAG.135   
      TNE= GAV(TTBR ,GWT,JGG,GAMDS ,NL,TEMP)*EFAC*.5                       GDIAG.136   
      TKZ= GAV(AKZ  ,GWT,JGG,DSIGMA,NL,TEMP)*EFAC                          GDIAG.137   
      TKE= GAV(AKE  ,GWT,JGG,DSIGMA,NL,TEMP)*EFAC                          GDIAG.138   
      TGZ= GAV(HBTBR,GWT,JGG,GAMDS ,NL,TEMP)*CFAC                          GDIAG.139   
      TGE= GAV(HTBR ,GWT,JGG,GAMDS ,NL,TEMP)*CFAC                          GDIAG.140   
      TDZ=-GAV(FUZR ,GWT,JGG,DSIGMA,NL,TEMP)*CFAC                          GDIAG.141   
      TDE=-GAV(FUER ,GWT,JGG,DSIGMA,NL,TEMP)*CFAC                          GDIAG.142   
      TCZ=-GAV(WBTBR,GWT,JGG,DSRSI ,NL,TEMP)*CFAC                          GDIAG.143   
      TCE=-GAV(WTBR ,GWT,JGG,DSRSI ,NL,TEMP)*CFAC                          GDIAG.144   
      TCSZ=TCZ*STMNN                                                       GDIAG.145   
      TCSE=TCE*STMNN                                                       GDIAG.146   
      TCZZ=TCZ-TCSZ                                                        GDIAG.147   
      TCEE=TCE-TCSE                                                        GDIAG.148   
      TCNSZ=-GAV(WBTBR,GWT,JGG,SDSRSI,NL,TEMP)*CFAC - TCSZ                 GDIAG.149   
      TCNSE=-GAV(WTBR ,GWT,JGG,SDSRSI,NL,TEMP)*CFAC - TCSE                 GDIAG.150   
      TCNZE=-GAV(DUMCN,GWT,JGG,DSIGMA,NL,TEMP)*CFAC                        GDIAG.151   
      TCKZE=-GAV(DUMCK,GWT,JGG,DSIGMA,NL,TEMP)*CFAC                        GDIAG.152   
      TNS = SDOT(NL,TMSQ(1)  ,1,GAMDS(1),1)*EFAC*.5                        GDIAG.153   
      TGS = SDOT(NL,HMTM(1)  ,1,GAMDS(1),1)*CFAC                           GDIAG.154   
      FIGZ=-SDOT(NL,GAMDS(1) ,1,TIGZ(1) ,1)*AKK                            GDIAG.155   
      FIGE=-SDOT(NL,GAMDS(1) ,1,TIGE(1) ,1)*AKK                            GDIAG.156   
      FIDZ= SDOT(NL,DSIGMA(1),1,TIDZ(1) ,1)*AKK                            GDIAG.157   
      FIDE= SDOT(NL,DSIGMA(1),1,TIDE(1) ,1)*AKK                            GDIAG.158   
      FRNS= SDOT(NL,DSIGMA(1),1,TRNS(1) ,1)*DAMP                           GDIAG.159   
      FRNZ=-SDOT(NL,GAMDS(1) ,1,TRNZ(1) ,1)*DAMP                           GDIAG.160   
      FRKZ= SDOT(NL,DSIGMA(1),1,TRKZ(1) ,1)*DAMP                           GDIAG.161   
      FDRZ= SDOT(NL,DSIGMA(1),1,TDRZ(1) ,1)                                GDIAG.162   
      FDRE= SDOT(NL,DSIGMA(1),1,TDRE(1) ,1)                                GDIAG.163   
C                                                                          GDIAG.164   
C     Accumulate time averages.                                            GDIAG.165   
C                                                                          GDIAG.166   
      IF (LTAV) THEN                                                       GDIAG.167   
         FD=FTAV                                                           GDIAG.168   
         IF (KOUNT.EQ.KSTART.OR.KOUNT.EQ.KEND) FD=.5*FD                    GDIAG.169   
         DO 40 N=1,NTERM5                                                  GDIAG.170   
   40    SEQV(N)=SEQV(N)+TEQV(N)*FD                                        GDIAG.171   
      ENDIF                                                                GDIAG.172   
C                                                                          GDIAG.173   
C     Write instantaneous values and also time averages at KEND.           GDIAG.174   
C                                                                          GDIAG.175   
      WRITE(NCGEN) KOUNT,DAY                                               GDIAG.176   
      WRITE(NCGEN) (TEQV(N),N=1,NTERM5),TMNN,WMNN,HMNN,STMNN               GDIAG.177   
      IF (KOUNT.EQ.KEND.AND.LTAV) THEN                                     GDIAG.178   
         JOUNT=-999                                                        GDIAG.179   
         TDAY=-999.                                                        GDIAG.180   
         WRITE(NCGEN) JOUNT,TDAY                                           GDIAG.181   
         WRITE(NCGEN) (SEQV(N),N=1,NTERM5),TDAY,TDAY,TDAY,TDAY             GDIAG.182   
      ENDIF                                                                GDIAG.183   
C                                                                          GDIAG.184   
C     Copy energetics values into time series arrays for plotting.         GDIAG.185   
C     These are sorted and copied to plot file at end of run.              GDIAG.186   
C                                                                          GDIAG.187   
      IF (LENCOP.AND.NPTS5.LT.NPMAX5) THEN                                 GDIAG.188   
         NPTS5=NPTS5+1                                                     GDIAG.189   
         IF (NPTS5.EQ.NPMAX5) WRITE(6,6030) DAY                            GDIAG.190   
         ADAY(NPTS5)=DAY                                                   GDIAG.191   
         AEN(NPTS5,1)=TNS                                                  GDIAG.192   
         AEN(NPTS5,2)=TNZ                                                  GDIAG.193   
         AEN(NPTS5,3)=TNE                                                  GDIAG.194   
         AEN(NPTS5,4)=TKZ                                                  GDIAG.195   
         AEN(NPTS5,5)=TKE                                                  GDIAG.196   
         ACONV(NPTS5, 1)= TCZ                                              GDIAG.197   
         ACONV(NPTS5, 2)= TCE                                              GDIAG.198   
         ACONV(NPTS5, 3)= TCNZE                                            GDIAG.199   
         ACONV(NPTS5, 4)= TCKZE                                            GDIAG.200   
         ACONV(NPTS5, 5)= TCNSZ                                            GDIAG.201   
         ACONV(NPTS5, 6)= TCNSE                                            GDIAG.202   
         ACONV(NPTS5, 7)= TGS                                              GDIAG.203   
         ACONV(NPTS5, 8)= TGZ                                              GDIAG.204   
         ACONV(NPTS5, 9)= TGE                                              GDIAG.205   
         ACONV(NPTS5,10)=-TDZ                                              GDIAG.206   
         ACONV(NPTS5,11)=-TDE                                              GDIAG.207   
         ACONV(NPTS5,12)= FIGZ                                             GDIAG.208   
         ACONV(NPTS5,13)= FIGE                                             GDIAG.209   
         ACONV(NPTS5,14)=-FIDZ                                             GDIAG.210   
         ACONV(NPTS5,15)=-FIDE                                             GDIAG.211   
      ENDIF                                                                GDIAG.212   
C                                                                          GDIAG.213   
      RETURN                                                               GDIAG.214   
C                                                                          GDIAG.215   
C     ----------------------------------------------------------------     GDIAG.216   
C                                                                          GDIAG.217   
C     End of run. Read time series of global terms and print.              GDIAG.218   
C                                                                          GDIAG.219   
  100 CONTINUE                                                             GDIAG.220   
      REWIND NCGEN                                                         GDIAG.221   
      IF (NPC5.NE.6) WRITE(NPC5,'(/////)')                                 GDIAG.222   
      WRITE(6,'(/////)')                                                   GDIAG.223   
C                                                                          GDIAG.224   
  110 CONTINUE                                                             GDIAG.225   
      READ(NCGEN) JOUNT,TDAY                                               GDIAG.226   
      READ(NCGEN) (TEQV(N),N=1,NTERM5),TMNN,WMNN,HMNN,STMNN                GDIAG.227   
      IF (JOUNT.GE.0) THEN                                                 GDIAG.228   
         IF (NPC5.NE.6) WRITE(NPC5,6000) TDAY                              GDIAG.229   
         WRITE(6,6000) TDAY                                                GDIAG.230   
      ELSE                                                                 GDIAG.231   
         IF (NPC5.NE.6) WRITE(NPC5,6010)                                   GDIAG.232   
         WRITE(6,6010)                                                     GDIAG.233   
      ENDIF                                                                GDIAG.234   
      IF (JOUNT.GE.0) THEN                                                 GDIAG.235   
         WMNN=WMNN*CMBHR                                                   GDIAG.236   
         TMNN=TMNN*CT                                                      GDIAG.237   
         HMNN=HMNN*CTT                                                     GDIAG.238   
         IF (NPC5.NE.6) WRITE(NPC5,6020) TMNN,WMNN,HMNN,STMNN              GDIAG.239   
         WRITE(6,6020) TMNN,WMNN,HMNN,STMNN                                GDIAG.240   
      ENDIF                                                                GDIAG.241   
      TEE=TKE+TNE                                                          GDIAG.242   
      TCZ=TCZZ+TCSZ                                                        GDIAG.243   
      TCE=TCEE+TCSE                                                        GDIAG.244   
      IF (NPC5.NE.6) THEN                                                  GDIAG.245   
         WRITE(NPC5,6100) TNS,TNZ,TNE,TKZ,TKE,TEE                          GDIAG.246   
         WRITE(NPC5,6110) TCNZE,TCZZ,TCSZ,TCNSZ,TCZ                        GDIAG.247   
     :                   ,TCKZE,TCEE,TCSE,TCNSE,TCE                        GDIAG.248   
         WRITE(NPC5,6120) TGS,TGZ,TGE,TDZ,TDE                              GDIAG.249   
         WRITE(NPC5,6130) FIGZ,FIGE,FIDZ,FIDE                              GDIAG.250   
         WRITE(NPC5,6140) FRNS,FRNZ,FRKZ,FDRZ,FDRE                         GDIAG.251   
      ENDIF                                                                GDIAG.252   
      WRITE(6,6100) TNS,TNZ,TNE,TKZ,TKE,TEE                                GDIAG.253   
      WRITE(6,6110) TCNZE,TCZZ,TCSZ,TCNSZ,TCZ                              GDIAG.254   
     :             ,TCKZE,TCEE,TCSE,TCNSE,TCE                              GDIAG.255   
      WRITE(6,6120) TGS,TGZ,TGE,TDZ,TDE                                    GDIAG.256   
      WRITE(6,6130) FIGZ,FIGE,FIDZ,FIDE                                    GDIAG.257   
      WRITE(6,6140) FRNS,FRNZ,FRKZ,FDRZ,FDRE                               GDIAG.258   
C                                                                          GDIAG.259   
      IF (JOUNT.GE.0.AND.JOUNT.LT.KEND) GOTO 110                           GDIAG.260   
      IF (JOUNT.EQ.KEND.AND.LTAV) GOTO 110                                 GDIAG.261   
C                                                                          GDIAG.262   
C     Sort and write time series of energies and conversions               GDIAG.263   
C     to plot file for use in subsequent job if required.                  GDIAG.264   
C                                                                          GDIAG.265   
      IF (.NOT.LENCOP) RETURN                                              GDIAG.266   
      WRITE(IYLAB (1:8),'(F8.3)') RNTAPE                                   GENPLT1.7     
      WRITE(IYLABA(1:8),'(F8.3)') RNTAPE                                   GENPLT1.8     
C                                                                          GENPLT1.9     
      IF (NPC5.NE.6) WRITE(NPC5,6040) ADAY(1),ADAY(NPTS5)                  GENPLT1.10    
      WRITE(6,6040) ADAY(1),ADAY(NPTS5)                                    GENPLT1.11    
      WRITE(NCPLOT(1),6040)  ADAY(1),ADAY(NPTS5)                           GENPLT1.12    
C                                                                          GENPLT1.13    
C     Energies.                                                            GENPLT1.14    
C                                                                          GENPLT1.15    
      WRITE(NCPLOT(1),'(''#'',A,A)') IYLAB,'  IN 10**4J/M2'                GENPLT1.16    
      WRITE(NCPLOT(1),'(''#'',6(4X,A,3X))') 'DAY',(ICAN(I),I=1,5)          GENPLT1.17    
      DO 210 N=1,NPTS5                                                     GENPLT1.18    
      WRITE(NCPLOT(1),'(6F10.4)') ADAY(N),(AEN(N,I)/1.0E4,I=1,5)           GENPLT1.19    
  210 CONTINUE                                                             GENPLT1.20    
C                                                                          GENPLT1.21    
C     Energy conversions.                                                  GENPLT1.22    
C                                                                          GENPLT1.23    
      WRITE(NCPLOT(1),'(''#''/''#'',A,A)') IYLABA,'  IN W/M2'              GENPLT1.24    
      WRITE(NCPLOT(1),'(''#'',7(4X,A,3X))') 'DAY',(ICANA(I),I=1,6)         GENPLT1.25    
      DO 220 N=1,NPTS5                                                     GENPLT1.26    
      WRITE(NCPLOT(1),'(7F10.4)') ADAY(N),(ACONV(N,I),I=1,6)               GENPLT1.27    
  220 CONTINUE                                                             GENPLT1.28    
C                                                                          GENPLT1.29    
C     Energy generation/dissipation rates from heating/friction.           GENPLT1.30    
C                                                                          GENPLT1.31    
      WRITE(NCPLOT(1),'(''#''/''#'',A,A)') IYLABA,'  IN W/M2'              GENPLT1.32    
      WRITE(NCPLOT(1),'(''#'',6(4X,A,3X))') 'DAY',(ICANA(I),I=7,11)        GENPLT1.33    
      DO 230 N=1,NPTS5                                                     GENPLT1.34    
      WRITE(NCPLOT(1),'(6F10.4)') ADAY(N),(ACONV(N,I),I=7,11)              GENPLT1.35    
  230 CONTINUE                                                             GENPLT1.36    
C                                                                          GENPLT1.37    
C     Energy generation/dissipation rates from hyperdiffusion.             GENPLT1.38    
C                                                                          GENPLT1.39    
      WRITE(NCPLOT(1),'(''#''/''#'',A,A)') IYLABA,'  IN W/M2'              GENPLT1.40    
      WRITE(NCPLOT(1),'(''#'',5(4X,A,3X))') 'DAY',(ICANA(I),I=12,15)       GENPLT1.41    
      DO 240 N=1,NPTS5                                                     GENPLT1.42    
      WRITE(NCPLOT(1),'(5F10.4)') ADAY(N),(ACONV(N,I),I=12,15)             GENPLT1.43    
  240 CONTINUE                                                             GENPLT1.44    
C                                                                          GDIAG.316   
      RETURN                                                               GDIAG.317   
      END                                                                  GDIAG.318   
C     ****************************************************************     GDIAG.319   
*DECK INIMSK                                                               INIMSK.1     
      SUBROUTINE INIMSK                                                    INIMSK.2     
C                                                                          INIMSK.3     
C     Initialise orographic mask fields for current analysis time.         INIMSK.4     
C     Write fields to data transfer file (UTF) if required.                INIMSK.5     
C                                                                          INIMSK.6     
*CALL PARAM1                                                               INIMSK.7     
*CALL PARAM2                                                               INIMSK.8     
*CALL BATS                                                                 INIMSK.9     
*CALL BLANK                                                                INIMSK.10    
*CALL COMIOC                                                               INIMSK.11    
*CALL COMMSK                                                               INIMSK.12    
*CALL COMPRL                                                               INIMSK.13    
*CALL COMROG                                                               INIMSK.14    
*CALL COMUTF                                                               UTF14.141   
*CALL OUTCON                                                               INIMSK.16    
*CALL MSKEQV                                                               INIMSK.17    
      REAL P3MIN(JGG),P3AV(JGG)                                            INIMSK.18    
      EQUIVALENCE (P3MIN(1),P3MSK(1,1)),(P3AV(1),P3MSK(1,2))               INIMSK.19    
      LOGICAL LOM2,LOM3                                                    INIMSK.20    
      CHARACTER*50 CNAME2,CNAME3                                           UTF14.142   
      SAVE CNAME2,CNAME3                                                   UTF14.143   
C                                                                          UTF14.144   
      DATA CNAME2/'MASK2 SURFACE PRESSURE                  HPA       '/    UTF14.145   
      DATA CNAME3/'MASK3 MIN AND AV PRESSURE               HPA       '/    UTF14.146   
C                                                                          INIMSK.26    
 6000 FORMAT(/' ***ABORT IN INIMSK: 2-D MASK ARRAY TOO LARGE FOR'          INIMSK.27    
     :       ,' EQUIVALENCING IN GRIDP: IGH, IGMX =',2I10)                 UTF14.147   
C                                                                          INIMSK.29    
C     Check common GRIDP is long enough for equivalenced mask array        INIMSK.30    
C     Must occupy only from UG to PMSLG, to avoid isentropic arrays.       INIMSK.31    
C***  NB.  This calculation depends on the size/ordering of GRIDP.         INIMSK.32    
C                                                                          INIMSK.33    
      IGMX=(18*NL+4)*IGC                                                   UTF14.148   
      IF (IGH.GT.IGMX) THEN                                                UTF14.149   
         WRITE(6,6000) IGH,IGMX                                            UTF14.150   
         CALL ABORT                                                        INIMSK.37    
      ENDIF                                                                INIMSK.38    
C                                                                          INIMSK.39    
C     Preset full surface pressure mask array to zero.                     INIMSK.40    
C     Set mask switches for this analysis time.  Return if no masks.       INIMSK.41    
C                                                                          INIMSK.42    
      DO 10 J=1,JGG                                                        UTF14.151   
         DO 10 I=1,MG                                                      UTF14.152   
            P2MSK(I,J)=0.                                                  UTF14.153   
   10 CONTINUE                                                             UTF14.154   
      LOM2=LMSK2.AND.(LOUTA.OR.LOUTF)                                      INIMSK.46    
      LOM3=LMSK3.AND.(LOUTA.OR.LOUTF)                                      INIMSK.47    
      IF (.NOT.(LOM2.OR.LOM3)) RETURN                                      INIMSK.48    
C                                                                          INIMSK.49    
C     Read surface pressure field directly into lat-long mask array.       INIMSK.50    
C                                                                          INIMSK.51    
      NC=NCGP(11)                                                          INIMSK.52    
      REWIND NC                                                            INIMSK.53    
      DO 20 J=1,JG                                                         INIMSK.54    
      IF (NHEM.EQ.1) THEN                                                  INIMSK.55    
         READ(NC) (P2MSK(I,J),I=1,MG)                                      INIMSK.56    
      ELSE                                                                 INIMSK.57    
         JS=JGGP-J                                                         UTF14.155   
         READ(NC) (P2MSK(I,J),I=1,MG),(DUM,I=1,2),(P2MSK(I,JS),I=1,MG)     INIMSK.59    
      ENDIF                                                                INIMSK.60    
   20 CONTINUE                                                             INIMSK.61    
      REWIND NC                                                            INIMSK.62    
C                                                                          INIMSK.63    
C     Normalise so that 0 -> P0 becomes 0 -> 1000.                         INIMSK.64    
C     Obtain zonal mean and minimum surface pressure at each latitude.     INIMSK.65    
C     Use to form remaining mask fields.                                   INIMSK.66    
C                                                                          INIMSK.67    
      PMFAC=1000.                                                          INIMSK.68    
      DO 50 IHEM=1,NHEM                                                    INIMSK.69    
         DO 50 J=1,JG                                                      UTF14.156   
            JJ=(2-IHEM)*J + (IHEM-1)*(JGGP-J)                              UTF14.157   
            ZPAV=0.                                                        UTF14.158   
            ZPMIN=PMFAC*P2MSK(1,JJ)                                        UTF14.159   
            DO 40 I=1,MG                                                   UTF14.160   
               P2MSK(I,JJ)=PMFAC*P2MSK(I,JJ)                               UTF14.161   
               ZPMIN=MIN(ZPMIN,P2MSK(I,JJ))                                UTF14.162   
               ZPAV=ZPAV+P2MSK(I,JJ)                                       UTF14.163   
   40       CONTINUE                                                       UTF14.164   
         P3AV(JJ)=ZPAV*RMG                                                 UTF14.165   
         P3MIN(JJ)=ZPMIN                                                   UTF14.166   
   50 CONTINUE                                                             UTF14.167   
C                                                                          INIMSK.79    
C     Prepare UTF header for current analysis time (or time average).      UTF14.168   
C                                                                          UTF14.169   
      IF (LOUTA) THEN                                                      UTF14.170   
         IF (DAY.GE.0) THEN                                                UTF14.171   
            WRITE(CFR2,'(A,F10.2,22X)') CFR2D(1:18),DAY                    UTF14.172   
         ELSE                                                              UTF14.173   
            CFR2=CFR2T                                                     UTF14.174   
         ENDIF                                                             UTF14.175   
      ENDIF                                                                UTF14.176   
C                                                                          UTF14.177   
C     Lat-long mask: prepare and write to UTF if required.                 INIMSK.89    
C     Check that lowest pressure level intersects orography.               INIMSK.90    
C                                                                          INIMSK.91    
      IF (LOM2) THEN                                                       INIMSK.92    
         CALL GPREP(P2MSK,IGH,0.,0.,GNORM,GINC,ICNT,P2MIN,P2MAX,IFAIL)     UTF14.178   
         IF (((PPR(NLPR)*PMFAC).GT.P2MIN).AND.LOUTA) THEN                  INIMSK.94    
            CALL UTFWI(MG,JGG,IZGTYP,0,3,0,1,0,0,IASCII,0,0,0,0,0,IFR3)    UTF14.179   
            CALL U14WF(P2MSK,IFR3,CNAME2,CFR2,P2MIN,P2MAX,GINC,NPCA)       UTF14.180   
         ENDIF                                                             INIMSK.97    
      ENDIF                                                                INIMSK.98    
C                                                                          INIMSK.99    
C     Zonal mean mask: write to UTF if required.                           INIMSK.100   
C                                                                          INIMSK.101   
      IF (LOM3.AND.LOUTA) THEN                                             UTF14.181   
         CALL GPREP(P3MSK,JGG*2,0.,0.,GNORM,GINC,ICNT,GMIN,GMAX,IFAIL)     UTF14.182   
         CALL UTFWI(JGG,2,11,0,4,2,1,0,0,IASCII,0,0,0,0,0,IFR3)            UTF14.183   
         CALL U14WF(P3MSK,IFR3,CNAME3,CFR2,GMIN,GMAX,GINC,NPCA)            UTF14.184   
      ENDIF                                                                UTF14.185   
C                                                                          INIMSK.104   
      RETURN                                                               INIMSK.105   
      END                                                                  INIMSK.106   
C     ****************************************************************     INIMSK.107   
*DECK OPGRID                                                               OPGRID.1     
      SUBROUTINE OPGRID                                                    OPGRID.2     
C                                                                          OPGRID.3     
C     Organise output of grid point data on model or pressure levels.      OPGRID.4     
C     NB.  Uses common SPECTR as workspace for GPV array.                  OPGRID.5     
C                                                                          OPGRID.6     
*CALL PARAM1                                                               OPGRID.7     
*CALL PARAM2                                                               OPGRID.8     
*CALL BATS                                                                 OPGRID.9     
*CALL BLANK                                                                OPGRID.10    
*CALL COMIOC                                                               OPGRID.11    
*CALL COMPRL                                                               OPGRID.12    
*CALL COMROG                                                               OPGRID.13    
*CALL OUTCON                                                               OPGRID.15    
*CALL PHYS                                                                 OPGRID.16    
*CALL SPECTR                                                               OPGRID.17    
      REAL GPV(IGD*JG),DFAC(NSG)                                           OPGRID.18    
      EQUIVALENCE (GPV(1),Z(1))                                            OPGRID.19    
      LOGICAL LOUTGR,LOUTPL                                                OPGRID.20    
      CHARACTER NAMES(NSG)*50                                              OPGRID.21    
      SAVE NAMES                                                           OPGRID.22    
C                                                                          OPGRID.23    
      DATA (NAMES(N),N=1,NSG)/                                             OPGRID.24    
     1 'STREAM FUNCTION                          M2/S     '                OPGRID.25    
     2,'RELATIVE VORTICITY                       S-1      '                OPGRID.26    
     3,'DIVERGENCE                               S-1      '                OPGRID.27    
     4,'OMEGA                                    MB/HR    '                OPGRID.28    
     5,'ZONAL WIND                               M/S      '                OPGRID.29    
     6,'MERIDIONAL WIND                          M/S      '                OPGRID.30    
     7,'TEMPERATURE                              DEG C    '                OPGRID.31    
     8,'GEOPOTENTIAL HEIGHT                      METRES   '                OPGRID.32    
     9,'SPECIFIC HUMIDITY                        G/KG     '                OPGRID.33    
     :,'DIABATIC HEATING                         K/DAY    '                OPGRID.34    
     1,'SURFACE PRESSURE                         MB       '                OPGRID.35    
     2,'MSL PRESSURE                             MB       '                OPGRID.36    
     :/                                                                    OPGRID.37    
C                                                                          OPGRID.38    
 6000 FORMAT(' PROCESSING SIGMA G-P FIELDS  AT DAY',F10.2,' KOUNT=',I10)   OPGRID.39    
C                                                                          OPGRID.40    
C     Write headers.                                                       OPGRID.41    
C                                                                          OPGRID.42    
      IF (NPC2.NE.6) THEN                                                  OPGRID.43    
         IF (LOUTP) WRITE(NPC2,'(///)')                                    OPGRID.44    
         WRITE(NPC2,6000) DAY,KOUNT                                        OPGRID.45    
      ENDIF                                                                OPGRID.46    
      WRITE(6,6000) DAY,KOUNT                                              OPGRID.47    
C                                                                          OPGRID.48    
C     Dimensionalising factors.                                            OPGRID.49    
C                                                                          OPGRID.50    
      DFAC(1)=RADEA*CV                                                     OPGRID.51    
      DFAC(2)=WW                                                           OPGRID.52    
      DFAC(3)=WW                                                           OPGRID.53    
      DFAC(4)=CMBHR                                                        OPGRID.54    
      DFAC(5)=CV                                                           OPGRID.55    
      DFAC(6)=CV                                                           OPGRID.56    
      DFAC(7)=CT                                                           OPGRID.57    
      DFAC(8)=CG/GA                                                        OPGRID.58    
      DFAC(9)=CQ                                                           OPGRID.59    
      DFAC(10)=CTT                                                         OPGRID.60    
      DFAC(11)=P0/100.                                                     OPGRID.61    
      DFAC(12)=P0/100.                                                     OPGRID.62    
C                                                                          OPGRID.63    
C     Loop over fields, each stored on a separate scratch file.            OPGRID.64    
C                                                                          OPGRID.65    
      DO 10 IOUT=1,NSG                                                     OPGRID.66    
      LOUTGR=LSGGR(IOUT)                                                   OPGRID.67    
      LOUTPL=LSGPL(IOUT)                                                   OPGRID.68    
      IF (.NOT.((LOUTP.AND.LOUTGR)                                         OPGRID.69    
     :          .OR.((LOUTF.OR.LOUTA).AND.LOUTPL))) GOTO 10                OPGRID.70    
      IF (IOUT.EQ.10.AND.KOUNT.LE.KBEGP) GOTO 10                           OPGRID.71    
      IF (IOUT.EQ.11.AND..NOT.LROG) GOTO 10                                OPGRID.72    
      NC=NCGP(IOUT)                                                        OPGRID.73    
      NLOUT=NL                                                             OPGRID.74    
      IF (LINTP2) NLOUT=NLPR                                               OPGRID.75    
      IF (IOUT.EQ.11) NLOUT=1                                              OPGRID.76    
      IF (IOUT.EQ.12) NLOUT=1                                              OPGRID.77    
      IPTYP=IZGTYP                                                         OPGRID.78    
      ICSTYL=0                                                             OPGRID.79    
      IF ((IOUT.EQ.1.OR.IOUT.EQ.7).AND..NOT.LSGEDY) ICSTYL=1               OPGRID.80    
      AFAC=SGFAC(IOUT)                                                     OPGRID.81    
      FINC=SGINC(IOUT)                                                     OPGRID.82    
      CALL OUTSUB(GPV,NAMES(IOUT),NC,NLOUT,DFAC(IOUT),AFAC,FINC            OPGRID.83    
     :           ,LOUTGR,LOUTPL,IPTYP,ICSTYL,IOUT)                         OPGRID.84    
   10 CONTINUE                                                             OPGRID.85    
C                                                                          OPGRID.86    
      RETURN                                                               OPGRID.87    
      END                                                                  OPGRID.88    
C     ****************************************************************     OPGRID.89    
*DECK OUTSUB                                                               OUTSUB.1     
      SUBROUTINE OUTSUB(GPV,NAME,NC,NLOUT,DFAC,AFAC,CINC                   OUTSUB.2     
     :                 ,LOUTGR,LOUTPL,IPTYP,ICSTYL,IOUT)                   OUTSUB.3     
C                                                                          OUTSUB.4     
C     To print plot and dump a global (multilevel for NLOUT.GT.1) field.   OUTSUB.5     
C     If NC <= 0, GPV contains data, otherwise read from channel NC.       OUTSUB.6     
C     Certain values of IOUT give special functions :                      OUTSUB.7     
C       IOUT=2  :  Subtract planetary vorticity after reading.             OUTSUB.8     
C       IOUT=4  :  Halve the contour interval at level L=NLOUT.            OUTSUB.9     
C       IOUT=5  :  Zonal wind : divide by cos(lat) after reading.          OUTSUB.10    
C       IOUT=6  :  Meridional wind : ditto plus zonal averages are *10.    OUTSUB.11    
C       IOUT=7  :  Temperature : subtract 273.15K to obtain Celcius.       OUTSUB.12    
C       IOUT=12 :  MSL pressure : subtract reference pressure in DFAC.     OUTSUB.13    
C     To avoid all of these for added fields use, eg. IOUT=0.              OUTSUB.14    
C                                                                          OUTSUB.15    
*CALL PARAM1                                                               OUTSUB.16    
*CALL PARAM2                                                               OUTSUB.17    
C                                                                          OUTSUB.19    
*CALL BATS                                                                 OUTSUB.20    
*CALL BLANK                                                                OUTSUB.21    
*CALL COMMSK                                                               OUTSUB.22    
*CALL COMPRL                                                               OUTSUB.23    
*CALL COMUTF                                                               UTF14.186   
*CALL DUM                                                                  OUTSUB.24    
*CALL LEGAU                                                                OUTSUB.25    
*CALL OUTCON                                                               OUTSUB.26    
      REAL GPV(MGPP,NHEM,NLOUT,JG)                                         OUTSUB.27    
      REAL GV(MG,JGG),GX(MG,JGG),GY(MG,JGG)                                UTF14.187   
      EQUIVALENCE (GV,GVE(1,1)),(GX,GVE(1,2)),(GY,GVE(1,3))                OUTSUB.29    
      LOGICAL LPRINT,LPLOT,LDUMP,LOUTGR,LOUTPL,LVEC,LXY,LZ                 OUTSUB.31    
      LOGICAL LTRUE                                                        BUGS3.8     
      CHARACTER*50 NAME                                                    UTF14.188   
C                                                                          OUTSUB.33    
 6000 FORMAT(/' DAY',F10.2,'  NUMBER OF TIME STEPS COMPLETED =',I10)       OUTSUB.34    
C                                                                          OUTSUB.35    
C     Set switches.  Write header.                                         OUTSUB.36    
C                                                                          OUTSUB.37    
      LVEC=.FALSE.                                                         SUNMOD.65    
      LPRINT=LOUTP.AND.LOUTGR                                              BUGS5.32    
      LZ=(LPRINT.AND.LSGGRZ).OR.                                           BUGS5.33    
     :   (LOUTPL.AND.LSGPLZ.AND.(NLOUT.GT.1).AND.(LOUTF.OR.LOUTA))         UTF14.189   
      IF (LPRINT) WRITE(NPC2,6000) DAY,KOUNT                               OUTSUB.43    
C                                                                          UTF14.190   
C     Prepare UTF header for current analysis time (or time average).      UTF14.191   
C                                                                          UTF14.192   
      IF (LOUTA) THEN                                                      UTF14.193   
         IF (DAY.GE.0) THEN                                                UTF14.194   
            WRITE(CFR2,'(A,F10.2,22X)') CFR2D(1:18),DAY                    UTF14.195   
         ELSE                                                              UTF14.196   
            CFR2=CFR2T                                                     UTF14.197   
         ENDIF                                                             UTF14.198   
      ENDIF                                                                UTF14.199   
C                                                                          OUTSUB.44    
C     Read data as JG records from scratch file if necessary.              OUTSUB.45    
C                                                                          OUTSUB.46    
      IF (NC.GT.0) THEN                                                    OUTSUB.47    
         REWIND NC                                                         OUTSUB.48    
         DO 10 J=1,JG                                                      OUTSUB.49    
   10    READ(NC) (((GPV(I,IHEM,L,J),I=1,MGPP),IHEM=1,NHEM),L=1,NLOUT)     OUTSUB.50    
         REWIND NC                                                         OUTSUB.51    
      ENDIF                                                                OUTSUB.52    
C                                                                          OUTSUB.53    
C     Dimensionalise and add offset as required.                           OUTSUB.54    
C     Winds are obtained by dividing by cos(lat).                          OUTSUB.55    
C                                                                          OUTSUB.56    
      DFACT=DFAC                                                           OUTSUB.57    
      OFF=0.                                                               OUTSUB.58    
      IF (IOUT.EQ.12) OFF=-DFAC                                            OUTSUB.59    
      DO 20 IHEM=1,NHEM                                                    OUTSUB.60    
      DO 20 J=1,JG                                                         OUTSUB.61    
      IF (IOUT.EQ.2) OFF=-2.*SI(J)*(3-2*IHEM)*DFAC                         OUTSUB.62    
      IF (IOUT.EQ.5.OR.IOUT.EQ.6) DFACT=DFAC/CS(J)                         OUTSUB.63    
      DO 20 L=1,NLOUT                                                      OUTSUB.64    
      IF (IOUT.EQ.7) OFF=-273.15                                           OUTSUB.65    
      DO 20 I=1,MG                                                         OUTSUB.66    
   20 GPV(I,IHEM,L,J)=GPV(I,IHEM,L,J)*DFACT+OFF                            OUTSUB.67    
C                                                                          OUTSUB.68    
C     ----------------------------------------------------------------     OUTSUB.69    
C     Loop over levels.                                                    OUTSUB.70    
C     Set switches for printing, plotting and dumping.                     OUTSUB.71    
C                                                                          OUTSUB.72    
      DO 60 L=1,NLOUT                                                      OUTSUB.73    
C                                                                          OUTSUB.74    
      LPRINT=LOUTP.AND.LOUTGR                                              OUTSUB.75    
      LPLOT =LOUTF.AND.LOUTPL                                              OUTSUB.76    
      LDUMP =LOUTA.AND.LOUTPL                                              OUTSUB.77    
      IF (NLOUT.GT.1) THEN                                                 OUTSUB.78    
         LPRINT=LPRINT.AND.LGPO(L)                                         OUTSUB.79    
         LPLOT =LPLOT .AND.LGFO(L)                                         OUTSUB.80    
         LDUMP =LDUMP .AND.LGFO(L)                                         OUTSUB.81    
      ENDIF                                                                OUTSUB.82    
      LXY=LPRINT.OR.LPLOT.OR.LDUMP                                         OUTSUB.83    
      IF (.NOT.(LXY.OR.LZ)) GOTO 60                                        OUTSUB.84    
C                                                                          OUTSUB.85    
C     Calculate zonal average and set up 2-D array at current level.       OUTSUB.86    
C     Remove zonal average if required.                                    OUTSUB.87    
C                                                                          OUTSUB.88    
      DO 50 IHEM=1,NHEM                                                    OUTSUB.89    
      DO 50 J=1,JG                                                         OUTSUB.90    
      JJ=(2-IHEM)*J + (IHEM-1)*(JGGP-J)                                    UTF14.200   
      IF (LZ.OR.(LXY.AND.LSGEDY)) THEN                                     OUTSUB.92    
         ZAV=0.                                                            UTF14.201   
         DO 28 I=1,MG                                                      UTF14.202   
         ZAV=ZAV+GPV(I,IHEM,L,J)                                           UTF14.203   
   28    CONTINUE                                                          UTF14.204   
         GVZ(JJ,L)=ZAV*RMG                                                 UTF14.205   
      ENDIF                                                                OUTSUB.95    
      IF (.NOT.LXY) GOTO 50                                                OUTSUB.96    
      IF (LSGEDY) THEN                                                     OUTSUB.97    
         DO 30 I=1,MG                                                      OUTSUB.98    
         GV(I,JJ)=GPV(I,IHEM,L,J)-GVZ(JJ,L)                                UTF14.206   
   30    CONTINUE                                                          UTF14.207   
      ELSE                                                                 OUTSUB.100   
         DO 40 I=1,MG                                                      OUTSUB.101   
         GV(I,JJ)=GPV(I,IHEM,L,J)                                          UTF14.208   
   40    CONTINUE                                                          UTF14.209   
      ENDIF                                                                OUTSUB.103   
   50 CONTINUE                                                             OUTSUB.104   
      IF (.NOT.LXY) GOTO 60                                                OUTSUB.105   
C                                                                          OUTSUB.106   
C     Set up character title to pass to output routines.                   OUTSUB.107   
C                                                                          OUTSUB.108   
      IF (LSGEDY) THEN                                                     OUTSUB.109   
         WRITE(CFR1,'(''EDDY '',2A)') CFR1(1:35),CFR1(41:50)               UTF14.210   
      ELSE                                                                 OUTSUB.111   
         CFR1=NAME(1:50)                                                   UTF14.211   
      ENDIF                                                                OUTSUB.113   
      IF (NLOUT.GT.1) THEN                                                 OUTSUB.114   
         IF (LINTP2) THEN                                                  OUTSUB.115   
            WRITE(CFR1(1:40),'(A,'' PRESS='',F6.1,2X)')                    UTF14.212   
     :           CFR1(1:25),PLOUT(L)                                       UTF14.213   
            LTYP=2                                                         UTF14.214   
         ELSE                                                              OUTSUB.117   
            WRITE(CFR1(1:40),'(A,''   ETA='',F6.1,2X)')                    UTF14.215   
     :           CFR1(1:25),PLOUT(L)                                       UTF14.216   
            LTYP=0                                                         UTF14.217   
         ENDIF                                                             OUTSUB.119   
      ELSE                                                                 UTF14.218   
         LTYP=0                                                            UTF14.219   
      ENDIF                                                                OUTSUB.120   
C                                                                          OUTSUB.121   
C     Set switches for orographic mask.                                    OUTSUB.122   
C                                                                          OUTSUB.123   
      PMSKL=0.                                                             OUTSUB.124   
      IMSK=0                                                               OUTSUB.125   
      IF (LMSK2.AND.(LPLOT.OR.LDUMP).AND.(NLOUT.GT.1)) THEN                OUTSUB.126   
         PMSKL=PPR(L)*PMFAC                                                OUTSUB.127   
         IF (PMSKL.GT.P2MIN) IMSK=NINT(PMSKL)                              OUTSUB.128   
      ENDIF                                                                OUTSUB.129   
C                                                                          OUTSUB.130   
C     Set contour interval.                                                OUTSUB.131   
C                                                                          OUTSUB.132   
      FINC=CINC                                                            OUTSUB.133   
      IF (IOUT.EQ.4.AND.L.EQ.NL) FINC=.5*FINC                              OUTSUB.134   
C                                                                          OUTSUB.135   
C     Prepare and output the 2-D array at the current level.               UTF14.220   
C                                                                          UTF14.221   
      CALL GPREP(GV,IGH,AFAC,FINC,GNORM,GINC,ICNT,GMIN,GMAX,IFAIL)         UTF14.222   
      IF (IFAIL.NE.0) CALL GFAIL(IFAIL,LPRINT,LPLOT,LDUMP,CFR1,ICNT)       UTF14.223   
C                                                                          UTF14.224   
      IF (LPRINT) CALL GPRINT(GV,CFR1,GMIN,GMAX,GNORM,NPC2)                UTF14.225   
C                                                                          UTF14.226   
      IF (LDUMP) THEN                                                      UTF14.227   
         CALL UTFWI(MG,JGG,IPTYP,ICSTYL,0,LTYP,1,0,IMSK,IASCII,0,0,0,0,0   UTF14.228   
     :             ,IFR3)                                                  UTF14.229   
         CALL U14WF(GV,IFR3,CFR1,CFR2,GMIN,GMAX,GINC,NPCA)                 UTF14.230   
      ENDIF                                                                UTF14.231   
C                                                                          OUTSUB.153   
   60 CONTINUE                                                             OUTSUB.154   
C                                                                          OUTSUB.155   
C     ----------------------------------------------------------------     OUTSUB.156   
C     End of loop over levels.                                             OUTSUB.157   
C                                                                          OUTSUB.158   
C     Output zonal average of field.                                       OUTSUB.159   
C                                                                          OUTSUB.160   
      IF (LZ) THEN                                                         OUTSUB.161   
         LPRINT=LOUTP.AND.LOUTGR.AND.LSGGRZ                                OUTSUB.162   
         LPLOT =LOUTF.AND.LOUTPL.AND.LSGPLZ.AND.(NLOUT.GT.1)               UTF14.232   
         LDUMP =LOUTA.AND.LOUTPL.AND.LSGPLZ.AND.(NLOUT.GT.1)               UTF14.233   
         WRITE(CFR1,'(A,10X,A,''(ZAV)'')') NAME(1:25),NAME(41:50)          UTF14.234   
         ZFAC=AFAC                                                         OUTSUB.166   
         IF (IOUT.EQ.6) ZFAC=.1*AFAC                                       OUTSUB.167   
         CALL XSECT(GVZ,NLOUT,CFR1,NPC2,ZFAC,CINC,LPRINT,LPLOT,LDUMP       UTF14.235   
     :             ,ICSTYL,LTYP,0)                                         UTF14.236   
      ENDIF                                                                UTF14.237   
C                                                                          OUTSUB.174   
      RETURN                                                               OUTSUB.175   
      END                                                                  OUTSUB.176   
C     ****************************************************************     OUTSUB.177   
*DECK OPERTEL                                                              OPERTEL.1     
      SUBROUTINE OPERTEL                                                   OPERTEL.2     
C                                                                          OPERTEL.3     
C     Print, plot and dump fields on isentropic surfaces.                  OPERTEL.4     
C     Include phase-shifted wind vectors on plots.                         OPERTEL.5     
C     NB.  Uses common SPECTR as workspace for GPV array.                  OPERTEL.6     
C                                                                          OPERTEL.7     
*CALL PARAM1                                                               OPERTEL.8     
*CALL PARAM2                                                               OPERTEL.9     
C                                                                          OPERTEL.11    
*CALL BATS                                                                 OPERTEL.12    
*CALL BLANK                                                                OPERTEL.13    
*CALL COMIOC                                                               OPERTEL.14    
*CALL COMMSK                                                               OPERTEL.15    
*CALL COMUTF                                                               UTF14.238   
*CALL DUM                                                                  OPERTEL.16    
*CALL LEGAU                                                                OPERTEL.18    
*CALL OUTCON                                                               OPERTEL.19    
*CALL SPECTR                                                               OPERTEL.20    
      REAL GPV(MGPP,NHEM,NTHSF,JG,NTH)                                     OPERTEL.21    
      EQUIVALENCE (GPV(1,1,1,1,1),Z(1))                                    OPERTEL.22    
      REAL GV(MG,JGG),GX(MG,JGG),GY(MG,JGG)                                UTF14.239   
      EQUIVALENCE (GV,GVE(1,1)),(GX,GVE(1,2)),(GY,GVE(1,3))                OPERTEL.24    
      REAL DFAC(NTH)                                                       ANSI2.331   
      LOGICAL LPRINT,LPLOT,LDUMP,LVEC,LFALSE                               UTF14.240   
      CHARACTER*50 NAMES(NTH)                                              UTF14.241   
      SAVE NAMES                                                           OPERTEL.28    
C                                                                          OPERTEL.29    
      DATA NAMES/                                                          OPERTEL.30    
     1 'U-CPHASE                  THETA=         M/S      '                OPERTEL.31    
     2,'V                         THETA=         M/S      '                OPERTEL.32    
     3,'ERTEL POT VORT            THETA=         PVU      '                OPERTEL.33    
     4,'PRESSURE                  THETA=         MB       '/               OPERTEL.34    
C                                                                          OPERTEL.35    
 6000 FORMAT(' PROCESSING ISENTROPIC FIELDS AT DAY',F10.2,' KOUNT=',I10)   OPERTEL.36    
 6010 FORMAT(/' DAY',F10.2,'  NUMBER OF TIME STEPS COMPLETED =',I10)       OPERTEL.37    
C                                                                          OPERTEL.38    
C     Print headers.                                                       OPERTEL.39    
C                                                                          OPERTEL.40    
      IF (NPC6.NE.6) THEN                                                  OPERTEL.41    
         IF (LOUTP) WRITE(NPC6,'(///)')                                    OPERTEL.42    
         WRITE(NPC6,6000) DAY,KOUNT                                        OPERTEL.43    
      ENDIF                                                                OPERTEL.44    
      WRITE(6,6000) DAY,KOUNT                                              OPERTEL.45    
C                                                                          UTF14.242   
C     Prepare UTF header for current analysis time (or time average).      UTF14.243   
C                                                                          UTF14.244   
      IF (LOUTA) THEN                                                      UTF14.245   
         IF (DAY.GE.0) THEN                                                UTF14.246   
            WRITE(CFR2,'(A,F10.2,22X)') CFR2D(1:18),DAY                    UTF14.247   
         ELSE                                                              UTF14.248   
            CFR2=CFR2T                                                     UTF14.249   
         ENDIF                                                             UTF14.250   
      ENDIF                                                                UTF14.251   
C                                                                          OPERTEL.46    
C     Dimensionalising factors, switches.                                  OPERTEL.47    
C                                                                          OPERTEL.48    
      DFAC(1)=CV                                                           OPERTEL.49    
      DFAC(2)=CV                                                           OPERTEL.50    
      DFAC(3)=1.E6*CERT                                                    OPERTEL.51    
      DFAC(4)=P0/100.                                                      OPERTEL.52    
C                                                                          OPERTEL.53    
      IPTYP=IZGTYP                                                         OPERTEL.54    
      ICSTYL=0                                                             OPERTEL.55    
      LTYP=3                                                               UTF14.252   
      IRSKIP=1                                                             UTF14.253   
      ARSTD=THINC(1)                                                       UTF14.254   
      IMSK=0                                                               OPERTEL.57    
C                                                                          OPERTEL.58    
C     Read data as JG records from scratch file.                           OPERTEL.59    
C                                                                          OPERTEL.60    
      REWIND NCTHG                                                         OPERTEL.61    
      DO 10 J=1,JG                                                         OPERTEL.62    
      READ(NCTHG) ((((GPV(I,IHEM,L,J,K),I=1,MGPP),IHEM=1,NHEM)             OPERTEL.63    
     :                              ,L=1,NTHSF),K=1,4)                     OPERTEL.64    
   10 CONTINUE                                                             OPERTEL.65    
      REWIND NCTHG                                                         OPERTEL.66    
C                                                                          OPERTEL.67    
C     Dimensionalise fields, removing eastward phase speed.                OPERTEL.68    
C                                                                          OPERTEL.69    
      DO 20 IHEM=1,NHEM                                                    OPERTEL.70    
      DO 20 J=1,JG                                                         OPERTEL.71    
      OFF=-CPHASE*CS(J)                                                    OPERTEL.72    
      CUTOFF=.99/CS(J)+OFF                                                 OPERTEL.73    
      DO 20 L=1,NTHSF                                                      OPERTEL.74    
      DO 20 I=1,MG                                                         OPERTEL.75    
      UTEMP=GPV(I,IHEM,L,J,1)/CS(J)+OFF                                    OPERTEL.76    
      IF (UTEMP.GT.CUTOFF) THEN                                            SUNMOD.78    
        GPV(I,IHEM,L,J,1)=0.0                                              SUNMOD.79    
       ELSE                                                                SUNMOD.80    
        GPV(I,IHEM,L,J,1)=UTEMP*DFAC(1)                                    SUNMOD.81    
      ENDIF                                                                SUNMOD.82    
      GPV(I,IHEM,L,J,2)=GPV(I,IHEM,L,J,2)*DFAC(2)/CS(J)                    OPERTEL.78    
      GPV(I,IHEM,L,J,3)=GPV(I,IHEM,L,J,3)*DFAC(3)                          OPERTEL.79    
   20 GPV(I,IHEM,L,J,4)=GPV(I,IHEM,L,J,4)*DFAC(4)                          OPERTEL.80    
C                                                                          OPERTEL.81    
C     ----------------------------------------------------------------     OPERTEL.82    
C     Loop over fields.  First set switches.                               OPERTEL.83    
C                                                                          OPERTEL.84    
      DO 100 IOUT=1,NTH                                                    OPERTEL.85    
C                                                                          OPERTEL.86    
      LPRINT=LOUTP.AND.LTHGR(IOUT)                                         OPERTEL.87    
      LPLOT =LOUTF.AND.LTHPL(IOUT)                                         OPERTEL.88    
      LDUMP =LOUTA.AND.LTHPL(IOUT)                                         OPERTEL.89    
      LVEC=(LPLOT.OR.LDUMP).AND.IOUT.GT.2                                  OPERTEL.90    
      IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP)) GOTO 100                        OPERTEL.91    
      IF (LOUTP) WRITE(NPC6,6010) DAY,KOUNT                                OPERTEL.92    
C                                                                          OPERTEL.93    
C     Loop over isentropic levels for each field.                          OPERTEL.94    
C                                                                          OPERTEL.95    
      DO 60 L=1,NTHSF                                                      OPERTEL.96    
      FINC=THINC(IOUT)                                                     OPERTEL.97    
      IF (IOUT.EQ.3.AND.L.LE.2) FINC=2.*FINC                               OPERTEL.98    
      IF (IOUT.EQ.3.AND.L.GE.4) FINC=.5*FINC                               OPERTEL.99    
      DO 30 N=1,4                                                          OPERTEL.100   
      WRITE(NAMES(N)(33:36),'(F4.0)') THSURD(L)                            ANSI2.332   
   30 CONTINUE                                                             ANSI2.333   
C                                                                          OPERTEL.102   
C     Calculate zonal average and set up 2-D array at current level.       OPERTEL.103   
C                                                                          OPERTEL.104   
      DO 40 IHEM=1,NHEM                                                    OPERTEL.105   
      DO 40 J=1,JG                                                         OPERTEL.106   
      JJ=(2-IHEM)*J + (IHEM-1)*(JGGP-J)                                    UTF14.255   
      ZAV=0.                                                               UTF14.256   
      DO 28 I=1,MG                                                         UTF14.257   
      ZAV=ZAV+GPV(I,IHEM,L,J,IOUT)                                         UTF14.258   
   28 CONTINUE                                                             UTF14.259   
      GVZ(JJ,L)=ZAV*RMG                                                    UTF14.260   
      DO 40 I=1,MG                                                         OPERTEL.110   
      GV(I,JJ)=GPV(I,IHEM,L,J,IOUT)                                        OPERTEL.111   
   40 CONTINUE                                                             OPERTEL.112   
C                                                                          OPERTEL.113   
C     Copy wind components into vector arrays if wind vectors plotted.     OPERTEL.114   
C                                                                          OPERTEL.115   
      IF (LVEC) THEN                                                       OPERTEL.116   
         DO 50 IHEM=1,NHEM                                                 OPERTEL.117   
         DO 50 J=1,JG                                                      OPERTEL.118   
         JJ=(2-IHEM)*J + (IHEM-1)*(JGGP-J)                                 UTF14.261   
         DO 50 I=1,MG                                                      OPERTEL.120   
         GX(I,JJ)=GPV(I,IHEM,L,J,1)                                        OPERTEL.121   
         GY(I,JJ)=GPV(I,IHEM,L,J,2)                                        OPERTEL.122   
   50    CONTINUE                                                          OPERTEL.123   
         CALL GPREP(GX,IGH,0.,0.,UNORM,UINC,ICNT,UMIN,UMAX,IFAIL)          UTF14.262   
         CALL GPREP(GY,IGH,0.,0.,VNORM,VINC,ICNT,VMIN,VMAX,IFAIL)          UTF14.263   
      ENDIF                                                                OPERTEL.126   
C                                                                          OPERTEL.127   
C     Prepare 2-D array for output.  Set up factors and contour levels.    OPERTEL.128   
C     Then call required routines.                                         OPERTEL.129   
C                                                                          OPERTEL.130   
      CALL GPREP(GV,IGH,THFAC(IOUT),FINC                                   UTF14.264   
     :          ,GNORM,GINC,ICNT,GMIN,GMAX,IFAIL)                          UTF14.265   
      IF (IFAIL.NE.0) CALL GFAIL(IFAIL,LPRINT,LPLOT,LDUMP                  OPERTEL.133   
     :                          ,NAMES(IOUT)(1:40),ICNT)                   OPERTEL.134   
C                                                                          OPERTEL.135   
      IF (LPRINT) CALL GPRINT(GV,NAMES(IOUT),GMIN,GMAX,GNORM,NPC6)         OPERTEL.136   
C                                                                          OPERTEL.137   
      IF (LDUMP) THEN                                                      OPERTEL.138   
         CALL UTFWI(MG,JGG,IPTYP,ICSTYL,0,LTYP,1,0,IMSK,IASCII,0,0,0,0,0   UTF14.266   
     :             ,IFR3)                                                  UTF14.267   
         CALL U14WF(GV,IFR3,NAMES(IOUT),CFR2,GMIN,GMAX,GINC,NPCA)          UTF14.268   
         IF (LVEC) THEN                                                    UTF14.269   
            CALL UTFWI(MG,JGG,IPTYP,IRSKIP,1,LTYP,1,0,0,IASCII,0,0,0,0,0   UTF14.270   
     :                ,IFR3)                                               UTF14.271   
            CALL U14WF(GX,IFR3,NAMES(1),CFR2,UMIN,UMAX,ARSTD,NPCA)         UTF14.272   
            CALL UTFWI(MG,JGG,IPTYP,IRSKIP,2,LTYP,1,0,0,IASCII,0,0,0,0,0   UTF14.273   
     :                ,IFR3)                                               UTF14.274   
            CALL U14WF(GY,IFR3,NAMES(2),CFR2,VMIN,VMAX,ARSTD,NPCA)         UTF14.275   
         ENDIF                                                             UTF14.276   
      ENDIF                                                                OPERTEL.147   
C                                                                          OPERTEL.148   
      IF (.NOT.LPLOT) GOTO 60                                              OPERTEL.149   
C                                                                          OPERTEL.157   
   60 CONTINUE                                                             OPERTEL.158   
C                                                                          OPERTEL.159   
C     Print zonal average of field.                                        OPERTEL.160   
C                                                                          OPERTEL.161   
      IF (LPRINT) THEN                                                     UTF14.277   
         LFALSE=.FALSE.                                                    UTF14.278   
         ZFAC=THFAC(IOUT)                                                  UTF14.279   
         IF (IOUT.EQ.2) ZFAC=.1*ZFAC                                       UTF14.280   
         WRITE(CFR1,'(A,10X,A,''(ZAV)'')')                                 UTF14.281   
     :        NAMES(IOUT)(1:25),NAMES(IOUT)(41:50)                         UTF14.282   
         CALL XSECT(GVZ,NTHSF,CFR1,NPC6,ZFAC,0.,LPRINT,LFALSE,LFALSE       UTF14.283   
     :             ,ICSTYL,LTYP,0)                                         UTF14.284   
      ENDIF                                                                UTF14.285   
C                                                                          OPERTEL.169   
  100 CONTINUE                                                             OPERTEL.170   
C                                                                          OPERTEL.171   
C     ----------------------------------------------------------------     OPERTEL.172   
C                                                                          OPERTEL.173   
      RETURN                                                               OPERTEL.174   
      END                                                                  OPERTEL.175   
C     ****************************************************************     OPERTEL.176   
*DECK GPREP                                                                GPREP.1     
      SUBROUTINE GPREP(G,JXY,AFAC,CINC,GNORM,GINC,ICNT,GMIN,GMAX,IFAIL)    ANSI2.334   
C                                                                          GPREP.4     
C     Prepare an array for printing and plotting.                          GPREP.5     
C     Use AFAC to set up GNORM multiplying factor for printing.            GPREP.6     
C     Use CINC to set-up and check contour interval for plotting.          ANSI2.335   
C     NB. The field is NOT scaled or overwritten.                          ANSI2.336   
C     Options are:                                                         GPREP.10    
C        a) CINC.GT.0        Use input value of AFAC as scaling            GPREP.11    
C                            factor for printing.                          GPREP.12    
C                            Use input value of CINC as contour            GPREP.13    
C                            interval for plotting.                        GPREP.14    
C        b) CINC.LT.-1       For printing normalise max. abs. value        GPREP.15    
C                            of field to 1000.                             GPREP.16    
C                            For plotting normalise range of field         GPREP.17    
C                            to 1000. Contour interval is -CINC in         GPREP.18    
C                            normalised units.                             GPREP.19    
C        c) -1.LE.CINC.LT.0  For printing normalise max. abs. value        GPREP.20    
C                            of field to lie between 0.1 and 1 by          GPREP.21    
C                            removing powers of 10 only.                   GPREP.22    
C                            For plotting normalise range of field         GPREP.23    
C                            to lie between 0.1 and 1 by removing          GPREP.24    
C                            powers of 10 only. Contour interval is        GPREP.25    
C                            -CINC in normalised units.                    GPREP.26    
C     IFAIL values are as follows:                                         GPREP.27    
C        -3    :    input print factor & contour interval both zero.       GPREP.28    
C        -2    :    input print factor zero.                               GPREP.29    
C        -1    :    input contour interval zero.                           GPREP.30    
C         0    :    successful completion.                                 GPREP.31    
C         1    :    field has zero range :  no contours set up.            GPREP.32    
C         2    :    more than NCNT contours required.                      ANSI2.337   
C                                                                          ANSI2.338   
      PARAMETER(NCNT=50)                                                   ANSI2.339   
C                                                                          ANSI2.340   
      REAL G(JXY)                                                          ANSI2.341   
C                                                                          GPREP.36    
      IFAIL=0                                                              GPREP.37    
C                                                                          GPREP.38    
C     Find minimum and maximum values.                                     GPREP.39    
C                                                                          GPREP.40    
      GMAX=G(1)                                                            ANSI2.342   
      GMIN=G(1)                                                            ANSI2.343   
      DO 5 J=2,JXY                                                         ANSI2.344   
         GMAX=MAX(GMAX,G(J))                                               ANSI2.345   
         GMIN=MIN(GMIN,G(J))                                               ANSI2.346   
    5 CONTINUE                                                             ANSI2.347   
C                                                                          GPREP.45    
C     Check input arguments.                                               GPREP.46    
C                                                                          GPREP.47    
      IF (AFAC.EQ.0..AND.CINC.EQ.0.) THEN                                  GPREP.48    
         GNORM=0.                                                          GPREP.49    
         GINC=0.                                                           GPREP.50    
         ICNT=0                                                            GPREP.51    
         IFAIL=-3                                                          GPREP.52    
         RETURN                                                            GPREP.53    
      ELSE IF (AFAC.EQ.0.) THEN                                            GPREP.54    
         GNORM=0.                                                          GPREP.55    
         IFAIL=-2                                                          GPREP.56    
      ENDIF                                                                GPREP.57    
C                                                                          GPREP.58    
C     Check for zero range.                                                GPREP.59    
C                                                                          GPREP.60    
      ZAMAX=MAX(ABS(GMAX),ABS(GMIN))                                       SUNMOD.95    
      ZRANGE=GMAX-GMIN                                                     GPREP.62    
      IF (ZRANGE.LE.ZAMAX*1.E-10) THEN                                     GPREP.63    
         IF (AFAC.NE.0.) GNORM=1./AFAC                                     GPREP.64    
         GINC=0.                                                           GPREP.65    
         ICNT=0                                                            GPREP.66    
         IFAIL=1                                                           GPREP.67    
         RETURN                                                            GPREP.68    
      ENDIF                                                                GPREP.69    
C                                                                          GPREP.70    
C     Set up factor for printed output and contour levels for plotting.    GPREP.71    
C                                                                          GPREP.72    
      IF (CINC.GT.0) THEN                                                  GPREP.73    
         IF (AFAC.NE.0.) GNORM=1./AFAC                                     GPREP.74    
         GINC=CINC                                                         GPREP.75    
      ELSE IF (CINC.LT.-1.) THEN                                           GPREP.76    
         IF (AFAC.NE.0.) GNORM=1000./ZAMAX                                 GPREP.77    
         GINC=-ZRANGE*CINC/1000.                                           GPREP.78    
      ELSE IF (CINC.LT.0.) THEN                                            GPREP.79    
         IF (AFAC.NE.0.) THEN                                              GPREP.80    
            IEXP=LOG10(ZAMAX)*.99999                                       SUNMOD.93    
            IF (ZAMAX.GT.1.) IEXP=IEXP+1                                   GPREP.82    
            ZA10=10.**IEXP                                                 GPREP.83    
            GNORM=1000./ZA10                                               GPREP.84    
         ENDIF                                                             GPREP.85    
         IEXP=LOG10(ZRANGE)*.99999                                         SUNMOD.94    
         IF (ZRANGE.GT.1.) IEXP=IEXP+1                                     GPREP.87    
         ZA10=10.**IEXP                                                    GPREP.88    
         ZFRACT=ZRANGE/ZA10                                                GPREP.89    
         IF (ZFRACT.GT.0.5) THEN                                           GPREP.90    
            GINC=-ZA10*CINC                                                GPREP.91    
         ELSE IF (ZFRACT.GT.0.2) THEN                                      GPREP.92    
            GINC=-ZA10*CINC*0.5                                            GPREP.93    
         ELSE                                                              GPREP.94    
            GINC=-ZA10*CINC*0.2                                            GPREP.95    
         ENDIF                                                             GPREP.96    
      ELSE                                                                 GPREP.97    
         IF (AFAC.NE.0.) GNORM=1./AFAC                                     GPREP.98    
         GINC=0.                                                           GPREP.99    
         ICNT=0                                                            GPREP.100   
         IFAIL=-1                                                          GPREP.101   
         RETURN                                                            GPREP.102   
      ENDIF                                                                GPREP.103   
C                                                                          GPREP.104   
C     Check number of contours for the specified/computed interval.        ANSI2.348   
C                                                                          ANSI2.349   
      ILO=INT(GMIN/GINC)                                                   ANSI2.350   
      IF (GMIN.GE.0.) ILO=ILO+1                                            ANSI2.351   
      IHI=INT(GMAX/GINC)                                                   ANSI2.352   
      IF (GMAX.LE.0.) IHI=IHI-1                                            ANSI2.353   
      ICNT=1+IHI-ILO                                                       ANSI2.354   
      IF (ICNT.GT.NCNT) IFAIL=2                                            ANSI2.355   
      ICNT=MIN(ICNT,NCNT)                                                  ANSI2.356   
C                                                                          GPREP.119   
      RETURN                                                               GPREP.120   
      END                                                                  GPREP.121   
C     ****************************************************************     GPREP.122   
*DECK GFAIL                                                                GFAIL.1     
      SUBROUTINE GFAIL(IFAIL,LPRINT,LPLOT,LDUMP,NAME,ICNT)                 GFAIL.2     
C                                                                          GFAIL.3     
C     Check failure code from GPREP, printing warnings and                 GFAIL.4     
C     modifying logical switches as necessary.                             GFAIL.5     
C                                                                          GFAIL.6     
      LOGICAL LPRINT,LPLOT,LDUMP                                           GFAIL.7     
      CHARACTER NAME*(*)                                                   GFAIL.8     
C                                                                          GFAIL.9     
 6900 FORMAT(/' ***GFAIL: ',A,'     NOT PRINTED, PLOTTED OR DUMPED:'       GFAIL.10    
     :       ,' PRINT FACTOR AND CONTOUR INTERVAL BOTH ZERO')              GFAIL.11    
 6910 FORMAT(/' ***GFAIL: ',A,'     NOT PRINTED:'                          GFAIL.12    
     :       ,' PRINT FACTOR IS ZERO')                                     GFAIL.13    
 6920 FORMAT(/' ***GFAIL: ',A,'     NOT PLOTTED OR DUMPED:'                GFAIL.14    
     :       ,' CONTOUR INTERVAL IS ZERO')                                 GFAIL.15    
 6930 FORMAT(/' ***GFAIL: ',A,'     : FIELD HAS ZERO RANGE')               GFAIL.16    
 6940 FORMAT(/' ***GFAIL: ',A,' :   MORE THAN',I3,' CONTOURS REQUIRED')    ANSI2.357   
C                                                                          GFAIL.18    
      IF (IFAIL.EQ.-3) THEN                                                GFAIL.19    
         WRITE(6,6900) NAME                                                GFAIL.20    
         IF (LPRINT) LPRINT=.FALSE.                                        BUGS3.15    
         IF (LPLOT) LPLOT=.FALSE.                                          BUGS3.16    
         IF (LDUMP) LDUMP=.FALSE.                                          BUGS3.17    
      ELSE IF (IFAIL.EQ.-2) THEN                                           GFAIL.24    
         IF (LPRINT) WRITE(6,6910) NAME                                    GFAIL.25    
         IF (LPRINT) LPRINT=.FALSE.                                        BUGS3.18    
      ELSE IF (IFAIL.EQ.-1) THEN                                           GFAIL.27    
         IF (LPLOT.OR.LDUMP) WRITE(6,6920) NAME                            GFAIL.28    
         IF (LPLOT) LPLOT=.FALSE.                                          BUGS3.19    
         IF (LDUMP) LDUMP=.FALSE.                                          BUGS3.20    
      ELSE IF (IFAIL.EQ.1) THEN                                            GFAIL.31    
         WRITE(6,6930) NAME                                                GFAIL.32    
      ELSE IF (IFAIL.EQ.2) THEN                                            GFAIL.33    
         IF (LPLOT.OR.LDUMP) WRITE(6,6940) NAME,ICNT                       GFAIL.34    
      ENDIF                                                                GFAIL.35    
C                                                                          GFAIL.36    
      RETURN                                                               GFAIL.37    
      END                                                                  GFAIL.38    
C     ****************************************************************     GFAIL.39    
*DECK GPRINT                                                               GPRINT.1     
      SUBROUTINE GPRINT(GV,NAME,GMIN,GMAX,GNORM,NPC)                       GPRINT.2     
C                                                                          GPRINT.3     
C     To print an integer map of a single level (global) field.            GPRINT.4     
C     Hemispheres printed separately with longitude increasing downward.   GPRINT.5     
C     N Hem has equator on left, pole on right; S Hem has pole on left,    GPRINT.6     
C     equator on right, same as right-handed sections from XSECT.          GPRINT.7     
C     Input:                                                               GPRINT.8     
C        GV(MG,JGG)     Global field, north pole to equator (NHEM=1)       UTF14.286   
C                       or south pole (NHEM=2).                            UTF14.287   
C        NAME(char*50)  (1:40) name of field & type/value of level.        GPRINT.12    
C                       (41:50) Dimensional units of field.                GPRINT.13    
C        GMIN,GMAX      Min & max of field in dimensional units.           GPRINT.14    
C        GNORM          Normalising factor from GPREP to obtain field      GPRINT.15    
C                       values in range <1000.                             GPRINT.16    
C        NPC            Fortran channel for output.                        GPRINT.17    
C     All arguments unchanged on output.                                   GPRINT.18    
C                                                                          GPRINT.19    
*CALL PARAM1                                                               GPRINT.20    
*CALL PARAM2                                                               GPRINT.21    
*CALL OUTCON                                                               GPRINT.22    
      REAL GV(MG,JGG)                                                      UTF14.288   
      CHARACTER NAME*50,HEMANN(2)*25                                       GPRINT.24    
      SAVE HEMANN                                                          GPRINT.25    
C                                                                          GPRINT.26    
      DATA HEMANN/'EQUATOR........NORTH POLE'                              GPRINT.27    
     :           ,'SOUTH POLE........EQUATOR'/                             GPRINT.28    
C                                                                          GPRINT.29    
 6000 FORMAT(/1X,A,1PE10.3,A)                                              GPRINT.30    
 6001 FORMAT(/1X,A,F10.1,A)                                                GPRINT.31    
 6002 FORMAT(/1X,A,F10.3,A)                                                GPRINT.32    
 6010 FORMAT(16X,'MIN  MAX  =',1P,2(2X,E10.3),A)                           GPRINT.33    
 6020 FORMAT(1X,A)                                                         GPRINT.34    
 6030 FORMAT(1X,32I4)                                                      GPRINT.35    
C                                                                          GPRINT.36    
      ZUNIT=1./GNORM                                                       GPRINT.37    
      IF (ZUNIT.GT.1000..OR.ZUNIT.LE..099) THEN                            GPRINT.38    
         WRITE(NPC,6000) NAME(1:40),ZUNIT,NAME(41:50)                      GPRINT.39    
      ELSE IF (ZUNIT.GE.10.) THEN                                          GPRINT.40    
         WRITE(NPC,6001) NAME(1:40),ZUNIT,NAME(41:50)                      GPRINT.41    
      ELSE                                                                 GPRINT.42    
         WRITE(NPC,6002) NAME(1:40),ZUNIT,NAME(41:50)                      GPRINT.43    
      ENDIF                                                                GPRINT.44    
      WRITE(NPC,6010) GMIN,GMAX,NAME(41:50)                                GPRINT.45    
C                                                                          GPRINT.46    
      JEQ=1+(NLAT-1)*INLAT                                                 UTF14.289   
      WRITE(NPC,6020) HEMANN(1)                                            GPRINT.48    
      DO 10 I=INLONG,MG,INLONG                                             GPRINT.49    
      WRITE(NPC,6030) (NINT(GV(I,J)*GNORM),J=JEQ,1,-INLAT)                 UTF14.290   
   10 CONTINUE                                                             UTF14.291   
      IF (NHEM.EQ.2) THEN                                                  GPRINT.51    
         WRITE(NPC,6020) HEMANN(2)                                         GPRINT.52    
         DO 20 I=INLONG,MG,INLONG                                          GPRINT.53    
         WRITE(NPC,6030) (NINT(GV(I,J)*GNORM),J=JGG,JG+1,-INLAT)           UTF14.292   
   20    CONTINUE                                                          UTF14.293   
      ENDIF                                                                GPRINT.55    
C                                                                          GPRINT.56    
      RETURN                                                               GPRINT.57    
      END                                                                  GPRINT.58    
C     ****************************************************************     GPRINT.59    
*DECK FLXPRC                                                               FLXPRC.1     
      SUBROUTINE FLXPRC                                                    FLXPRC.2     
C                                                                          FLXPRC.3     
C     Print, plot and dump zonal averages of dynamical quantities          FLXPRC.4     
C     from common ZONAV for one analysis time.                             FLXPRC.5     
C     For KOUNT<0 time averages are copied from TAV and output.            FLXPRC.6     
C     All fields are temporarily dimensionised for output.                 FLXPRC.7     
C                                                                          FLXPRC.8     
*CALL PARAM1                                                               FLXPRC.9     
*CALL PARAM2                                                               FLXPRC.10    
*CALL BATS                                                                 FLXPRC.11    
*CALL BLANK                                                                FLXPRC.12    
*CALL COMPRL                                                               FLXPRC.13    
*CALL COMUTF                                                               UTF14.294   
*CALL OUTCON                                                               FLXPRC.14    
*CALL TAV                                                                  FLXPRC.15    
*CALL ZONAV                                                                FLXPRC.16    
      REAL DDZ(IGG,NXD),DDZT(IGG,NXD),DFAC(NXD)                            FLXPRC.17    
      EQUIVALENCE (DDZ(1,1),UBR(1,1)),(DDZT(1,1),UBT(1,1))                 FLXPRC.18    
      LOGICAL LPRINT,LPLOT,LDUMP,LARROW                                    UTF14.295   
      CHARACTER*50 NAME(NXD)                                               UTF14.296   
      SAVE NAME                                                            FLXPRC.21    
C                                                                          FLXPRC.22    
      DATA (NAME(J),J=1,15)/                                               UTF14.297   
     1 'ZONAL WIND                          M/S           '                UTF14.298   
     2,'POTENTIAL TEMPERATURE               KELVIN        '                UTF14.299   
     3,'TEMPERATURE                         DEG C         '                UTF14.300   
     4,'MEAN MERIDIONAL CIRCULATION         KG/S          '                UTF14.301   
     5,'HORIZONTAL EDDY MOMENTUM FLUX       (M/S)2        '                UTF14.302   
     6,'VERTICAL EDDY MOMENTUM FLUX         (M/S)(PA/S)   '                UTF14.303   
     7,'HORIZONTAL EDDY HEAT FLUX           K(M/S)        '                UTF14.304   
     8,'VERTICAL EDDY HEAT FLUX             K(PA/S)       '                UTF14.305   
     9,'ZONAL KINETIC ENERGY                J/KG          '                UTF14.306   
     :,'EDDY KINETIC ENERGY                 J/KG          '                UTF14.307   
     1,'NORTHWARD E-P FLUX                  (M3)(RAD)     '                UTF14.308   
     2,'UPWARD E-P FLUX                     (M3)(PA)      '                UTF14.309   
     3,'HORIZONTAL E-P FLUX DIVERGENCE      M3            '                UTF14.310   
     4,'VERTICAL E-P FLUX DIVERGENCE        M3            '                UTF14.311   
     5,'TOTAL E-P FLUX DIVERGENCE           M3            '                UTF14.312   
     :/                                                                    UTF14.313   
      DATA (NAME(J),J=16,28)/                                              UTF14.314   
     6 'STATIC STABILITY                    S-2           '                UTF14.315   
     7,'QY FOR VARYING NSQUARED             (S-1)(M-1)    '                UTF14.316   
     8,'TOTAL PERMITTED WAVENUMBER                        '                UTF14.317   
     9,'TEMPERATURE ANOMALY                 DEG C         '                UTF14.318   
     :,'MEAN VERTICAL MOTION                PA/S          '                UTF14.319   
     1,'VERTICAL MEAN HEAT FLUX             K(PA/S)       '                UTF14.320   
     2,'MEAN MERIDIONAL WIND                M/S           '                UTF14.321   
     3,'HORIZONTAL MEAN HEAT FLUX           K(M/S)        '                UTF14.322   
     4,'SPECIFIC HUMIDITY                   G/KG          '                UTF14.323   
     5,'RELATIVE HUMIDITY                   PER CENT      '                UTF14.324   
     6,'HORIZONTAL EDDY MOISTURE FLUX       (M/S)(G/KG)   '                UTF14.325   
     7,'VERTICAL EDDY MOISTURE FLUX         (PA/S)(G/KG)  '                UTF14.326   
     8,'TOTAL DIABATIC HEATING              K/DAY         '                UTF14.327   
     :/                                                                    UTF14.328   
      DATA (NAME(J),J=29,31)/                                              UTF14.329   
     9 'TEM RESIDUAL CIRCULATION            KG/S          '                UTF14.330   
     :,'TEM MERIDIONAL WIND                 M/S           '                UTF14.331   
     1,'TEM VERTICAL MOTION                 MB/HR         '                UTF14.332   
     :/                                                                    UTF14.333   
      DATA (NAME(J),J=32,39)/                                              UTF14.334   
     2 '[U*U*] VARIANCE                     M2/S2         '                UTF14.335   
     3,'[V*V*] VARIANCE                     M2/S2         '                UTF14.336   
     4,'[V*W*] CO-VARIANCE                  M/S(MB/HR)    '                UTF14.337   
     5,'[T*T*] VARIANCE                     K2            '                UTF14.338   
     6,'[H*T*] (GE INTEGRAND)               K2/DAY        '                UTF14.339   
     7,'[H][T] (GZ INTEGRAND)               K2/DAY        '                UTF14.340   
     8,'FUZR (KZ DISSIPATION)               M/S/DAY       '                UTF14.341   
     9,'FUER (KE DISSIPATION)               M/S/DAY       '                UTF14.342   
     :/                                                                    UTF14.343   
C                                                                          UTF14.344   
 6000 FORMAT(' PROCESSING DYNAMICS Z-SECTS  AT DAY',F10.2,' KOUNT=',I10)   FLXPRC.56    
 6010 FORMAT(' PROCESSING DYNAMICS Z-SECTS  FOR TIME AVERAGES')            FLXPRC.57    
C                                                                          FLXPRC.58    
C     Dimensionalising factors.                                            FLXPRC.59    
C                                                                          FLXPRC.60    
      DFAC(1)=CV                                                           FLXPRC.61    
      DFAC(2)=CT                                                           FLXPRC.62    
      DFAC(3)=CT                                                           FLXPRC.63    
      DFAC(4)=CV*P0*(PI2*RADEA/GA)                                         FLXPRC.64    
      DFAC(5)=CG                                                           FLXPRC.65    
      DFAC(6)=CV*CMBHR                                                     FLXPRC.66    
      DFAC(7)=CV*CT                                                        FLXPRC.67    
      DFAC(8)=CT*CMBHR                                                     FLXPRC.68    
      DFAC(9)=CG                                                           FLXPRC.69    
      DFAC(10)=CG                                                          FLXPRC.70    
      DFAC(11)=CEP                                                         FLXPRC.71    
      DFAC(12)=CEP*P0                                                      FLXPRC.72    
      DFAC(13)=CEP                                                         FLXPRC.73    
      DFAC(14)=CEP                                                         FLXPRC.74    
      DFAC(15)=CEP                                                         FLXPRC.75    
      DFAC(16)=GA*GA/(RD*CT)                                               FLXPRC.76    
      DFAC(17)=WW/RADEA                                                    FLXPRC.77    
      DFAC(18)=1.                                                          FLXPRC.78    
      DFAC(19)=CT                                                          FLXPRC.79    
      DFAC(20)=CMBHR                                                       FLXPRC.80    
      DFAC(21)=CT*CMBHR                                                    FLXPRC.81    
      DFAC(22)=CV                                                          FLXPRC.82    
      DFAC(23)=CV*CT                                                       FLXPRC.83    
      DFAC(24)=CQ                                                          FLXPRC.84    
      DFAC(25)=100.                                                        FLXPRC.85    
      DFAC(26)=CV*CQ                                                       FLXPRC.86    
      DFAC(27)=CQ*CMBHR                                                    FLXPRC.87    
      DFAC(28)=CTT                                                         FLXPRC.88    
C                                                                          XDTEM3.29    
      DFAC(29)=CV*P0*(PI2*RADEA/GA)                                        XDTEM3.30    
      DFAC(30)=CV                                                          XDTEM3.31    
      DFAC(31)=CMBHR                                                       XDTEM3.32    
C                                                                          XDTEM3.33    
      DFAC(32)=CG                                                          XDTEM3.34    
      DFAC(33)=CG                                                          XDTEM3.35    
      DFAC(34)=CV*CMBHR                                                    XDTEM3.36    
      DFAC(35)=CT*CT                                                       XDTEM3.37    
      DFAC(36)=CT*CTT                                                      XDTEM3.38    
      DFAC(37)=CT*CTT                                                      XDTEM3.39    
      DFAC(38)=CV*PI2                                                      XDTEM3.40    
      DFAC(39)=CV*PI2                                                      XDTEM3.41    
C                                                                          UTF14.345   
C     Prepare UTF header for current analysis time (or time average).      UTF14.346   
C                                                                          UTF14.347   
      IF (LOUTA) THEN                                                      UTF14.348   
         IF (DAY.GE.0) THEN                                                UTF14.349   
            WRITE(CFR2,'(A,F10.2,22X)') CFR2D(1:18),DAY                    UTF14.350   
         ELSE                                                              UTF14.351   
            CFR2=CFR2T                                                     UTF14.352   
         ENDIF                                                             UTF14.353   
      ENDIF                                                                UTF14.354   
C                                                                          UTF14.355   
C     Level type.                                                          UTF14.356   
C                                                                          UTF14.357   
      IF (LINTP3) THEN                                                     UTF14.358   
         LTYP=2                                                            UTF14.359   
      ELSE                                                                 UTF14.360   
         LTYP=0                                                            UTF14.361   
      ENDIF                                                                UTF14.362   
C                                                                          FLXPRC.92    
C     Print header.  Temporarily dimensionalise all fields.                FLXPRC.93    
C     For time averages, copy from common TAV into ZONAV.                  FLXPRC.94    
C                                                                          FLXPRC.95    
      IF (LOUTP.AND.NPC3.NE.6) WRITE(NPC3,'(///)')                         FLXPRC.96    
      IF (KOUNT.GE.0) THEN                                                 FLXPRC.97    
         IF (NPC3.NE.6) WRITE(NPC3,6000) DAY,KOUNT                         FLXPRC.98    
         WRITE(6,6000) DAY,KOUNT                                           FLXPRC.99    
         DO 10 IOUT=1,NXD                                                  FLXPRC.100   
         DO 10 I=1,IGG                                                     FLXPRC.101   
   10    DDZ(I,IOUT)=DDZ(I,IOUT)*DFAC(IOUT)                                FLXPRC.102   
      ELSE                                                                 FLXPRC.103   
         IF (NPC3.NE.6) WRITE(NPC3,6010)                                   FLXPRC.104   
         WRITE(6,6010)                                                     FLXPRC.105   
         DO 20 IOUT=1,NXD                                                  FLXPRC.106   
         DO 20 I=1,IGG                                                     FLXPRC.107   
   20    DDZ(I,IOUT)=DDZT(I,IOUT)*DFAC(IOUT)                               FLXPRC.108   
      ENDIF                                                                FLXPRC.109   
C                                                                          FLXPRC.110   
C     Main loop over fields.                                               FLXPRC.111   
C                                                                          FLXPRC.112   
      DO 30 IOUT=1,NXD                                                     FLXPRC.113   
      LPRINT=LOUTP.AND.LXDGR(IOUT)                                         FLXPRC.114   
      LPLOT =LOUTF.AND.LXDPL(IOUT)                                         FLXPRC.115   
      LDUMP =LOUTA.AND.LXDPL(IOUT)                                         FLXPRC.116   
      LARROW=IOUT.EQ.15.OR.IOUT.EQ.18                                      FLXPRC.117   
      IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP)) GOTO 30                         FLXPRC.118   
      IF (IOUT.EQ.19.AND.DAMP.LE.0.) GOTO 30                               FLXPRC.119   
      ICSTYL=0                                                             FLXPRC.121   
      IF (IOUT.EQ.3.OR.IOUT.EQ.15) ICSTYL=1                                UTF14.363   
      CALL XSECT(DDZ(1,IOUT),NL,NAME(IOUT),NPC3,XDFAC(IOUT),XDINC(IOUT)    UTF14.364   
     :          ,LPRINT,LPLOT,LDUMP,ICSTYL,LTYP,IOUT)                      UTF14.365   
      IF (LARROW.AND.LDUMP) THEN                                           UTF14.366   
         CALL GPREP(EPFH,JGG*NL,0.,0.,UNORM,UINC,ICNT,UMIN,UMAX,IFAIL)     UTF14.367   
         CALL UTFWI(JGG,NL,11,1,1,LTYP,0,0,0,IASCII,0,0,0,0,0,IFR3)        UTF14.368   
         CALL U14WF(EPFH,IFR3,NAME(11),CFR2,UMIN,UMAX,XDFAC(11),NPCA)      UTF14.369   
         CALL GPREP(EPFV,JGG*NL,0.,0.,VNORM,VINC,ICNT,VMIN,VMAX,IFAIL)     UTF14.370   
         CALL UTFWI(JGG,NL,11,1,2,LTYP,0,0,0,IASCII,0,0,0,0,0,IFR3)        UTF14.371   
         CALL U14WF(EPFV,IFR3,NAME(12),CFR2,VMIN,VMAX,XDFAC(11),NPCA)      UTF14.372   
      ENDIF                                                                UTF14.373   
   30 CONTINUE                                                             FLXPRC.135   
C                                                                          FLXPRC.136   
C     Non-dimensionalise all fields in case needed later.                  FLXPRC.137   
C                                                                          FLXPRC.138   
      DO 40 IOUT=1,NXD                                                     FLXPRC.139   
      DO 40 I=1,IGG                                                        FLXPRC.140   
   40 DDZ(I,IOUT)=DDZ(I,IOUT)/DFAC(IOUT)                                   FLXPRC.141   
C                                                                          FLXPRC.142   
      RETURN                                                               FLXPRC.143   
      END                                                                  FLXPRC.144   
C     ****************************************************************     FLXPRC.145   
*DECK XSECT                                                                XSECT.1     
      SUBROUTINE XSECT(F,NLOUT,NAME,NPC,AFAC,CINC,LPRINT,LPLOT,LDUMP       XSECT.2     
     :                ,ICSTYL,LTYP,IOUT)                                   UTF14.374   
C                                                                          XSECT.4     
C     To print, plot and dump a zonal cross-section.                       XSECT.5     
C     Used for all zonally averaged fields.  No film or dump to UTF        XSECT.6     
C     (ie print only) if NLOUT not equal NL.                               XSECT.7     
C     Includes orographic mask field if required.                          XSECT.8     
C     Prints hemispheres separately, both right handed.                    XSECT.9     
C     Certain values of IOUT have special functions:                       XSECT.10    
C        IOUT=2 : Supresses >NCNT contour warning for pot-temperature.     UTF14.375   
C        IOUT=3 : Temporarily subtract 273.15K from temperature.           XSECT.13    
C        IOUT=18: Only 11 contours for total permitted wavenumber.         XSECT.14    
C     To avoid all of these for added fields use e.g. IOUT=0.              XSECT.16    
C                                                                          XSECT.17    
*CALL PARAM1                                                               XSECT.18    
*CALL PARAM2                                                               XSECT.19    
*CALL BATS                                                                 XSECT.22    
*CALL COMMSK                                                               XSECT.23    
*CALL COMUTF                                                               UTF14.376   
*CALL OUTCON                                                               XSECT.24    
      REAL F(JGG,NLOUT)                                                    ANSI2.358   
      LOGICAL LPRINT,LPLOT,LDUMP                                           UTF14.377   
      CHARACTER NAME*50,HEMANN(2)*30,DIMANN(0:3)*5                         UTF14.378   
      SAVE HEMANN,DIMANN                                                   XSECT.28    
C                                                                          XSECT.29    
      DATA HEMANN/'EQUATOR.............NORTH POLE'                         XSECT.30    
     :           ,'SOUTH POLE.............EQUATOR'/                        XSECT.31    
      DATA DIMANN/'SIGMA','ETA  ','PRESS','THETA'/                         UTF14.379   
C                                                                          XSECT.33    
 6000 FORMAT(/1X,A,1PE10.3,A)                                              XSECT.34    
 6001 FORMAT(/1X,A,F10.1,A)                                                XSECT.35    
 6002 FORMAT(/1X,A,F10.3,A)                                                XSECT.36    
 6010 FORMAT(6X,'MIN  MAX  =',1P,2(2X,E10.3),A)                            XSECT.37    
 6020 FORMAT(' ZONAL MEAN',9X,15X,A)                                       XSECT.38    
 6030 FORMAT(' ZONAL MEAN ON ',A,15X,A)                                    XSECT.39    
 6040 FORMAT(1X,32I4)                                                      XSECT.40    
C                                                                          XSECT.41    
C     Set switches.                                                        XSECT.42    
C                                                                          XSECT.43    
      IPTYP=11                                                             XSECT.44    
      IMSK=0                                                               XSECT.45    
      IF (LMSK3.AND.(LPLOT.OR.LDUMP).AND.(LTYP.EQ.2)) IMSK=1               UTF14.380   
C                                                                          UTF14.381   
C     Prepare UTF header for current analysis time (or time average).      UTF14.382   
C                                                                          UTF14.383   
      IF (LDUMP) THEN                                                      UTF14.384   
         IF (DAY.GE.0) THEN                                                UTF14.385   
            WRITE(CFR2,'(A,F10.2,22X)') CFR2D(1:18),DAY                    UTF14.386   
         ELSE                                                              UTF14.387   
            CFR2=CFR2T                                                     UTF14.388   
         ENDIF                                                             UTF14.389   
      ENDIF                                                                UTF14.390   
C                                                                          XSECT.47    
C     Temporarily remove offset for temperature fields.                    XSECT.48    
C                                                                          XSECT.49    
      XOF=0.0                                                              UTF14.391   
      IF (IOUT.EQ.3) XOF=273.15                                            UTF14.392   
C                                                                          UTF14.393   
      IF (XOF.NE.0.0) THEN                                                 UTF14.394   
         DO 10 L=1,NLOUT                                                   XSECT.53    
         DO 10 J=1,JGG                                                     XSECT.54    
   10    F(J,L)=F(J,L)-XOF                                                 XSECT.55    
      ENDIF                                                                XSECT.56    
C                                                                          XSECT.57    
C     Set up printing factor, contour levels etc.                          XSECT.58    
C                                                                          XSECT.59    
      CALL GPREP(F,JGG*NLOUT,AFAC,CINC,GNORM,GINC,ICNT,GMIN,GMAX,IFAIL)    ANSI2.359   
      IF (.NOT.((IOUT.EQ.2.OR.IOUT.EQ.18).AND.IFAIL.EQ.2)) THEN            XSECT.64    
         IF (IFAIL.NE.0) CALL GFAIL(IFAIL,LPRINT,LPLOT,LDUMP               XSECT.65    
     :                             ,NAME(1:30),ICNT)                       XSECT.66    
      ENDIF                                                                XSECT.67    
C                                                                          XSECT.68    
C     Print field.                                                         XSECT.69    
C                                                                          XSECT.70    
      IF (LPRINT) THEN                                                     XSECT.71    
         ZUNIT=1./GNORM                                                    XSECT.72    
         IF (ZUNIT.GT.1000..OR.ZUNIT.LE..099) THEN                         XSECT.73    
            WRITE(NPC,6000) NAME(1:30),ZUNIT,NAME(31:45)                   XSECT.74    
         ELSE IF (ZUNIT.GE.10.) THEN                                       XSECT.75    
            WRITE(NPC,6001) NAME(1:30),ZUNIT,NAME(31:45)                   XSECT.76    
         ELSE                                                              XSECT.77    
            WRITE(NPC,6002) NAME(1:30),ZUNIT,NAME(31:45)                   XSECT.78    
         ENDIF                                                             XSECT.79    
         WRITE(NPC,6010) GMIN,GMAX,NAME(31:45)                             XSECT.80    
         DO 40 IHEM=1,NHEM                                                 XSECT.81    
         IF (NLOUT.EQ.1) THEN                                              UTF14.395   
            WRITE(NPC,6020) HEMANN(IHEM)                                   XSECT.83    
         ELSE                                                              XSECT.84    
            WRITE(NPC,6030) DIMANN(LTYP),HEMANN(IHEM)                      UTF14.396   
         ENDIF                                                             XSECT.86    
         JEQ=1+(NLAT-1)*INLAT                                              UTF14.397   
         IF (IHEM.EQ.1) THEN                                               XSECT.88    
            DO 20 L=1,NLOUT                                                XSECT.89    
            WRITE(NPC,6040) (NINT(F(J,L)*GNORM),J=JEQ,1,-INLAT)            UTF14.398   
   20       CONTINUE                                                       UTF14.399   
         ELSE                                                              XSECT.91    
            DO 30 L=1,NLOUT                                                XSECT.92    
            WRITE(NPC,6040) (NINT(F(J,L)*GNORM),J=JGG,JGP,-INLAT)          UTF14.400   
   30       CONTINUE                                                       UTF14.401   
         ENDIF                                                             XSECT.94    
   40    CONTINUE                                                          XSECT.95    
      ENDIF                                                                XSECT.96    
C                                                                          XSECT.97    
C     Dump field to data transfer file.                                    XSECT.102   
C                                                                          XSECT.103   
      IF (LDUMP) THEN                                                      XSECT.104   
         CALL UTFWI(JGG,NLOUT,IPTYP,ICSTYL,0,LTYP,1,0,IMSK,IASCII          UTF14.402   
     :             ,0,0,0,0,0,IFR3)                                        UTF14.403   
         CALL U14WF(F,IFR3,NAME,CFR2,GMIN,GMAX,GINC,NPCA)                  UTF14.404   
      ENDIF                                                                XSECT.111   
C                                                                          XSECT.112   
C     Add back the temporarily removed offset.                             XSECT.117   
C                                                                          XSECT.118   
      IF (XOF.NE.0.0) THEN                                                 UTF14.405   
         DO 50 L=1,NLOUT                                                   UTF14.406   
         DO 50 J=1,JGG                                                     XSECT.121   
   50    F(J,L)=F(J,L)+XOF                                                 XSECT.122   
      ENDIF                                                                XSECT.123   
C                                                                          XSECT.124   
      RETURN                                                               XSECT.125   
      END                                                                  XSECT.126   
C     ****************************************************************     XSECT.127   
*DECK FUNC                                                                 FUNC.1     
      FUNCTION EDX(X,Y,Z,KDUM)                                             FUNC.2     
      REAL X(*),Y(*),Z(*)                                                  FUNC.3     
      DO 10 I=1,KDUM                                                       FUNC.4     
      Z(I)=Z(I)+(Y(I)-X(I))*(Y(I)+X(I))                                    FUNC.5     
   10 CONTINUE                                                             FUNC.6     
      EDX=0.                                                               FUNC.7     
      RETURN                                                               FUNC.8     
      END                                                                  FUNC.9     
      FUNCTION EDY(X,Y,Z,KDUM)                                             FUNC.10    
      REAL X(*),Y(*),Z(*)                                                  FUNC.11    
      DO 10 I=1,KDUM                                                       FUNC.12    
      Z(I)=Z(I)-X(I)*Y(I)                                                  FUNC.13    
   10 CONTINUE                                                             FUNC.14    
      EDY=0.                                                               FUNC.15    
      RETURN                                                               FUNC.16    
      END                                                                  FUNC.17    
      FUNCTION EKKE(X,Y,Z,KDUM)                                            FUNC.18    
      REAL X(*),Y(*),Z(*)                                                  FUNC.19    
      DO 10 I=1,KDUM                                                       FUNC.20    
      Z(I)=Z(I)+0.5*(X(I)*X(I)+Y(I)*Y(I))                                  FUNC.21    
   10 CONTINUE                                                             FUNC.22    
      EKKE=0.                                                              FUNC.23    
      RETURN                                                               FUNC.24    
      END                                                                  FUNC.25    
      FUNCTION XYT(X,Y,Z,KDUM)                                             FUNC.26    
      REAL X(*),Y(*),Z(*)                                                  FUNC.27    
      DO 10 I=1,KDUM                                                       FUNC.28    
      Z(I)=Z(I)+X(I)*Y(I)                                                  FUNC.29    
   10 CONTINUE                                                             FUNC.30    
      XYT=0.                                                               FUNC.31    
      RETURN                                                               FUNC.32    
      END                                                                  FUNC.33    
C     ******************************************************************   FUNC.34    
*DECK INITF                                                                INITF.1     
      SUBROUTINE INITF(BEGDAY,ENDDAY)                                      INITF.2     
C                                                                          INITF.3     
C     Initialise transient flux calculations, set up work files.           INITF.4     
C                                                                          INITF.5     
*CALL PARAM1                                                               INITF.6     
*CALL PARAM2                                                               INITF.7     
*CALL BLANK                                                                INITF.8     
*CALL OUTCON                                                               INITF.9     
*CALL COMIOC                                                               INITF.10    
*CALL TIMFLX                                                               INITF.11    
      WRITE(6,'(/,A)') ' INITIALISATION OF TRANSIENT FLUXES'               INITF.12    
      IF (NTF.GT.8) THEN                                                   INITF.13    
         WRITE(6,'(/,2A)') ' ***ABORT IN INITF: MORE THAN 8 FLUXES: '      INITF.14    
     *                    ,' WORK FILES FOR TRANSIENT FLUXES WILL CLASH'   INITF.15    
        CALL ABORT                                                         INITF.16    
      ENDIF                                                                INITF.17    
C                                                                          INITF.18    
C     Initialise work files.                                               INITF.19    
C                                                                          INITF.20    
      DO 10 J=1,6                                                          INITF.21    
      DO 10 I=1,IGD                                                        INITF.22    
      AVER(I,J)=0.0                                                        INITF.23    
   10 CONTINUE                                                             INITF.24    
      DO 30 ITF=1,NTF                                                      INITF.25    
      DO 20 J=1,JG                                                         INITF.26    
      WRITE(ITF+NCTFI) AVER                                                INITF.27    
   20 CONTINUE                                                             INITF.28    
      REWIND ITF+NCTFI                                                     INITF.29    
      REWIND ITF+NCTFO                                                     INITF.30    
   30 CONTINUE                                                             INITF.31    
C                                                                          INITF.32    
C     Check diagnostic period.                                             INITF.33    
C                                                                          INITF.34    
      NDAYTT=NINT((ENDDAY-BEGDAY)*TSPD/KOUNTD)+1                           INITF.35    
      NPER=NDAYTT/NFIL                                                     INITF.36    
      TEND=(NPER*NFIL-1)*KOUNTD/TSPD+BEGDAY                                INITF.37    
      WRITE(6,'(A,F10.3,A,F10.3,A,I5)')                                    INITF.38    
     *     ' BEGDAY = ',BEGDAY,',  ENDDAY = ',ENDDAY                       INITF.39    
     *    ,',  NO OF ANALYSES = ',NDAYTT                                   INITF.40    
      WRITE(6,'(A,I5,A)')                                                  INITF.41    
     *     ' LENGTH OF LOW PASS AVERAGING BLOCK = ',NFIL,' ANALYSES'       INITF.42    
      WRITE(6,'(A,I5)') ' NO OF BLOCKS = ',NPER                            INITF.43    
C                                                                          INITF.44    
      IF (NPER.EQ.0) THEN                                                  INITF.45    
         LTFLUX=.FALSE.                                                    INITF.46    
         WRITE(6,'(A/A)')                                                  INITF.47    
     *    ' *** DIAGNOSTIC PERIOD LESS THAN LOW PASS AVERAGING PERIOD'     INITF.48    
     *   ,' *** TRANSIENT FLUXES SWITCHED OFF'                             INITF.49    
      ELSE IF (ABS(TEND-ENDDAY).GT.1.E-5) THEN                             INITF.50    
         WRITE(6,'(/A/A/A/A,F10.3/A)')                                     INITF.51    
     *    ' ***************       ABORT IN INITF        ***************'   INITF.52    
     *   ,' DIAGNOSTIC PERIOD MUST BE A MULTIPLE OF LOW PASS AV. PERIOD'   INITF.53    
     *   ,' INITF WOULD ATTEMPT TO MODIFY ENDDAY BUT CORRUPT TR-FLUXES'    INITF.54    
     *   ,' TRY RESUBMITTING WITH ENDDAY = ',TEND                          INITF.55    
     *   ,' ***************       ABORT IN INITF        ***************'   INITF.56    
         CALL ABORT                                                        INITF.57    
      ENDIF                                                                INITF.58    
C                                                                          INITF.59    
C     Constants/counters defining accumulation/filtering.                  INITF.60    
C     IPER   counter of analyses within current low-pass period.           INITF.61    
C     RPASS  counter of low-pass periods.                                  INITF.62    
C     RFIL   normalisation for a single low-pass period.                   INITF.63    
C                                                                          INITF.64    
      IPER=0                                                               INITF.65    
      RPASS=0.                                                             INITF.66    
      RFIL=1./NFIL                                                         INITF.67    
C                                                                          INITF.68    
      RETURN                                                               INITF.69    
      END                                                                  INITF.70    
C     ******************************************************************   INITF.71    
*DECK TFILT                                                                TFILT.1     
      SUBROUTINE TFILT(JH)                                                 TFILT.2     
C                                                                          TFILT.3     
C     Organise transient flux calculations at the current analysis time    TFILT.4     
C     and current latitude for all fluxes.                                 TFILT.5     
C     JH is the latitude counter.                                          TFILT.6     
C                                                                          TFILT.7     
*CALL PARAM1                                                               TFILT.8     
*CALL PARAM2                                                               TFILT.9     
*CALL COMIOC                                                               TFILT.10    
*CALL TIMFLX                                                               TFILT.11    
*CALL GRIDP                                                                TFILT.12    
      EXTERNAL EDX,EDY,EKKE,XYT                                            TFILT.13    
C                                                                          TFILT.14    
C     Update analysis counter within the current low pass period.          TFILT.15    
C                                                                          TFILT.16    
      IF (JH.EQ.1) IPER=IPER+1                                             TFILT.17    
C                                                                          TFILT.18    
C     Compute and accumulate individual fluxes.                            TFILT.19    
C                                                                          TFILT.20    
      CALL TFLUX(UG,VG,EDX,1)                                              TFILT.21    
      CALL TFLUX(UG,VG,EDY,2)                                              TFILT.22    
      CALL TFLUX(UG,VG,EKKE,3)                                             TFILT.23    
      CALL TFLUX(UG,TG,XYT,4)                                              TFILT.24    
      CALL TFLUX(VG,TG,XYT,5)                                              TFILT.25    
C                                                                          TFILT.26    
C     Rewind work files, swap channel numbers, increment counters.         TFILT.27    
C                                                                          TFILT.28    
      IF (JH.EQ.JG) THEN                                                   TFILT.29    
         DO 10 ITF=1,NTF                                                   TFILT.30    
         REWIND NCTFO+ITF                                                  TFILT.31    
         REWIND NCTFI+ITF                                                  TFILT.32    
   10    CONTINUE                                                          TFILT.33    
         IT=NCTFI                                                          TFILT.34    
         NCTFI=NCTFO                                                       TFILT.35    
         NCTFO=IT                                                          TFILT.36    
         IF (IPER.EQ.NFIL) THEN                                            TFILT.37    
            IPER=0                                                         TFILT.38    
            RPASS=RPASS+1.0                                                TFILT.39    
         ENDIF                                                             TFILT.40    
      ENDIF                                                                TFILT.41    
C                                                                          TFILT.42    
      RETURN                                                               TFILT.43    
      END                                                                  TFILT.44    
C     ******************************************************************   TFILT.45    
*DECK TFLUX                                                                TFLUX.1     
      SUBROUTINE TFLUX(XG,YG,FCT,ITF)                                      TFLUX.2     
C                                                                          TFLUX.3     
C     Accumulate a single transient flux at the current latitude and       TFLUX.4     
C     analysis time.                                                       TFLUX.5     
C     Dummy argument FCT is the name of the function which creates the     TFLUX.6     
C     required transient flux.                                             TFLUX.7     
C     The work files contain at each latitude 6 longitude-height arrays:   TFLUX.8     
C        AVER(i,1)  total flux, accum over entire diagnostic period,       TFLUX.9     
C        AVER(i,2)  X, accum over current low-pass period,                 TFLUX.10    
C        AVER(i,3)  Y, accum over current low-pass period,                 TFLUX.11    
C        AVER(i,4)  X, accum over entire diagnostic period,                TFLUX.12    
C        AVER(i,5)  Y, accum over entire diagnostic period,                TFLUX.13    
C        AVER(i,6)  low-pass flux, accum over entire diagnostic period.    TFLUX.14    
C     The low-pass flux uses averages of the input fields over non-        TFLUX.15    
C     overlapping low-pass periods.                                        TFLUX.16    
C                                                                          TFLUX.17    
*CALL PARAM1                                                               TFLUX.18    
*CALL PARAM2                                                               TFLUX.19    
*CALL COMIOC                                                               TFLUX.20    
*CALL TIMFLX                                                               TFLUX.21    
      REAL XG(IGD),YG(IGD)                                                 TFLUX.22    
C                                                                          TFLUX.23    
      READ(NCTFI+ITF) AVER                                                 TFLUX.24    
C                                                                          TFLUX.25    
C     Accumulate the total-flux.                                           TFLUX.26    
C                                                                          TFLUX.27    
      FAIL=FCT(XG,YG,AVER(1,1),IGD)                                        TFLUX.28    
C                                                                          TFLUX.29    
C     Accumulate X,Y averages within the current low-pass period.          TFLUX.30    
C                                                                          TFLUX.31    
      DO 10 I=1,IGD                                                        TFLUX.32    
      AVER(I,2)=AVER(I,2)+XG(I)                                            TFLUX.33    
      AVER(I,3)=AVER(I,3)+YG(I)                                            TFLUX.34    
   10 CONTINUE                                                             TFLUX.35    
C                                                                          TFLUX.36    
C     Calculations at the last analysis of a low-pass period.              TFLUX.37    
C                                                                          TFLUX.38    
      IF (IPER.EQ.NFIL) THEN                                               TFLUX.39    
C                                                                          TFLUX.40    
C        Accumulate the long-term X,Y averages.                            TFLUX.41    
C                                                                          TFLUX.42    
         DO 20 I=1,IGD                                                     TFLUX.43    
         AVER(I,4)=AVER(I,4)+AVER(I,2)                                     TFLUX.44    
         AVER(I,5)=AVER(I,5)+AVER(I,3)                                     TFLUX.45    
   20    CONTINUE                                                          TFLUX.46    
C                                                                          TFLUX.47    
C        Accumulate the low-pass flux.                                     TFLUX.48    
C                                                                          TFLUX.49    
         FAIL=FCT(AVER(1,2),AVER(1,3),AVER(1,6),IGD)                       TFLUX.50    
C                                                                          TFLUX.51    
C        Reset the X,Y low-pass averages for the next period.              TFLUX.52    
C                                                                          TFLUX.53    
         DO 30 I=1,IGD                                                     TFLUX.54    
         AVER(I,2)=0.0                                                     TFLUX.55    
         AVER(I,3)=0.0                                                     TFLUX.56    
   30    CONTINUE                                                          TFLUX.57    
C                                                                          TFLUX.58    
      ENDIF                                                                TFLUX.59    
C                                                                          TFLUX.60    
      WRITE(NCTFO+ITF) AVER                                                TFLUX.61    
C                                                                          TFLUX.62    
      RETURN                                                               TFLUX.63    
      END                                                                  TFLUX.64    
C     ******************************************************************   TFLUX.65    
*DECK TFLUXE                                                               TFLUXE.1     
      SUBROUTINE TFLUXE                                                    TFLUXE.2     
C                                                                          TFLUXE.3     
C     Organise the transient fluxes ready for output at the end of the     TFLUXE.4     
C     diagnostic period.                                                   TFLUXE.5     
C     TFLUXD computes and normalises the final total, high and low-pass    TFLUXE.6     
C     fields for a single flux.                                            TFLUXE.7     
C                                                                          TFLUXE.8     
*CALL PARAM1                                                               TFLUXE.9     
*CALL PARAM2                                                               TFLUXE.10    
*CALL COMIOC                                                               TFLUXE.11    
*CALL LEGAU                                                                TFLUXE.12    
*CALL BLANK                                                                TFLUXE.13    
*CALL TIMFLX                                                               TFLUXE.14    
      EXTERNAL EDX,EDY,EKKE,XYT                                            TFLUXE.15    
C                                                                          TFLUXE.16    
C     Normalisation for low-pass flux accumulation, equal to the           TFLUXE.17    
C     reciprocal of (NHIGH**2)*(NLOW),                                     TFLUXE.18    
C     where NHIGH is number of analyses in a single low-pass period,       TFLUXE.19    
C     and NLOW is number of low-pass periods.                              TFLUXE.20    
C                                                                          TFLUXE.21    
      RPASS=RFIL*RFIL/RPASS                                                TFLUXE.22    
C                                                                          TFLUXE.23    
      DO 10 J=1,JG                                                         TFLUXE.24    
      DIM=CV*CV*SECSQ(J)                                                   TFLUXE.25    
      CALL TFLUXD(DIM,EDX,1)                                               TFLUXE.26    
      CALL TFLUXD(DIM,EDY,2)                                               TFLUXE.27    
      CALL TFLUXD(DIM,EKKE,3)                                              TFLUXE.28    
      DIM=CT*CV/CS(J)                                                      TFLUXE.29    
      CALL TFLUXD(DIM,XYT,4)                                               TFLUXE.30    
      CALL TFLUXD(DIM,XYT,5)                                               TFLUXE.31    
   10 CONTINUE                                                             TFLUXE.32    
C                                                                          TFLUXE.33    
      DO 20 ITF=1,NTF                                                      TFLUXE.34    
      REWIND ITF+NCTFO                                                     TFLUXE.35    
      REWIND ITF+NCTFI                                                     TFLUXE.36    
   20 CONTINUE                                                             TFLUXE.37    
C                                                                          TFLUXE.38    
      RETURN                                                               TFLUXE.39    
      END                                                                  TFLUXE.40    
C     ******************************************************************   TFLUXE.41    
*DECK TFLUXD                                                               TFLUXD.1     
      SUBROUTINE TFLUXD(DIM,FCT,ITF)                                       TFLUXD.2     
C                                                                          TFLUXD.3     
C     Compute and normalise the final total, high and low-pass fields      TFLUXD.4     
C     for a single flux at the current latitude.                           TFLUXD.5     
C     Note that the input total and low-pass fluxes include the            TFLUXD.6     
C     stationary component.                                                TFLUXD.7     
C     Note that all 6 parts of AVER are included in the output array,      TFLUXD.8     
C     in order to keep the same work file record length, though the        TFLUXD.9     
C     6th component is redundent.                                          TFLUXD.10    
C                     Input                 Output                         TFLUXD.11    
C        AVER(i,1)  total flux accum    total-transient flux               TFLUXD.12    
C        AVER(i,2)  (stationary flux)   high-pass transient flux           TFLUXD.13    
C        AVER(i,3)                      low-pass transient flux            TFLUXD.14    
C        AVER(i,4)  accumulated X       time-average X                     TFLUXD.15    
C        AVER(i,5)  accumulated Y       time-average Y                     TFLUXD.16    
C        AVER(i,6)  low-pass accum      zero                               TFLUXD.17    
C                                                                          TFLUXD.18    
*CALL PARAM1                                                               TFLUXD.19    
*CALL PARAM2                                                               TFLUXD.20    
*CALL COMIOC                                                               TFLUXD.21    
*CALL TIMFLX                                                               TFLUXD.22    
C                                                                          TFLUXD.23    
      READ(NCTFI+ITF) AVER                                                 TFLUXD.24    
C                                                                          TFLUXD.25    
C     Preset stationary flux term in (,2).                                 TFLUXD.26    
C     Normalise time averages of linear input fields.                      TFLUXD.27    
C     RAV is the total number of analyses in the accumulation.             TFLUXD.28    
C                                                                          TFLUXD.29    
      DO 10 I=1,IGD                                                        TFLUXD.30    
      AVER(I,2)=0.0                                                        TFLUXD.31    
      AVER(I,4)=AVER(I,4)/RAV                                              TFLUXD.32    
      AVER(I,5)=AVER(I,5)/RAV                                              TFLUXD.33    
   10 CONTINUE                                                             TFLUXD.34    
C                                                                          TFLUXD.35    
C     Compute stationary flux.                                             TFLUXD.36    
C                                                                          TFLUXD.37    
      FAIL=FCT(AVER(1,4),AVER(1,5),AVER(1,2),IGD)                          TFLUXD.38    
C                                                                          TFLUXD.39    
C     Compute and normalise total-transient and low-pass fluxes.           TFLUXD.40    
C                                                                          TFLUXD.41    
      DO 20 I=1,IGD                                                        TFLUXD.42    
      AVER(I,1)=DIM*(AVER(I,1)/RAV-AVER(I,2))                              TFLUXD.43    
      AVER(I,3)=DIM*(RPASS*AVER(I,6)-AVER(I,2))                            TFLUXD.44    
   20 CONTINUE                                                             TFLUXD.45    
C                                                                          TFLUXD.46    
C     High-pass flux is difference between total and low-pass.             TFLUXD.47    
C     Reset last unused array to zero.                                     TFLUXD.48    
C                                                                          TFLUXD.49    
      DO 30 I=1,IGD                                                        TFLUXD.50    
      AVER(I,2)=AVER(I,1)-AVER(I,3)                                        TFLUXD.51    
      AVER(I,6)=0.0                                                        TFLUXD.52    
   30 CONTINUE                                                             TFLUXD.53    
C                                                                          TFLUXD.54    
      WRITE(NCTFO+ITF) AVER                                                TFLUXD.55    
C                                                                          TFLUXD.56    
      RETURN                                                               TFLUXD.57    
      END                                                                  TFLUXD.58    
C     ******************************************************************   TFLUXD.59    
*DECK TFPLOT                                                               TFPLOT.1     
      SUBROUTINE TFPLOT                                                    TFPLOT.2     
C                                                                          TFPLOT.3     
C     Output the transient fluxes.                                         TFPLOT.4     
C     This version omits the previous extra scratch file for a single      TFPLOT.5     
C     3D global flux array and reads each field into a global 3D array.    TFPLOT.6     
C     The spectral commmon block is used as workspace for the 3D array.    TFPLOT.7     
C     separate swiches for lat-long and zonal mean fields are obtained     TFPLOT.8     
C     from the common block /TIMFLX/.                                      TFPLOT.9     
C     The levels at which the lat-long fields are output are determined    TFPLOT.10    
C     by arrays LGPO, LGFO in common /OUTCON/.  The zonal sections         TFPLOT.11    
C     include all levels.                                                  TFPLOT.12    
C                                                                          TFPLOT.13    
*CALL PARAM1                                                               TFPLOT.14    
*CALL PARAM2                                                               TFPLOT.15    
*CALL BLANK                                                                TFPLOT.16    
*CALL BATS                                                                 TFPLOT.17    
*CALL COMIOC                                                               TFPLOT.18    
*CALL OUTCON                                                               TFPLOT.19    
*CALL COMPRL                                                               TFPLOT.20    
*CALL SPECTR                                                               TFPLOT.21    
*CALL TIMFLX                                                               TFPLOT.22    
      CHARACTER NAME(NTFFLD)*50                                            TFPLOT.23    
      LOGICAL LPRINT,LPLOT,LDUMP                                           TFPLOT.24    
      REAL GPV(IGD,JG),GAV(JGG,NL)                                         TFPLOT.25    
      EQUIVALENCE (GPV(1,1),Z(1))                                          TFPLOT.26    
C                                                                          TFPLOT.27    
      DATA NAME/                                                           TFPLOT.28    
     1 '  E-Vector(X), TOTAL FLUX          '                               TFPLOT.29    
     1,'  E-Vector(X), HIGH PASS           '                               TFPLOT.30    
     1,'  E-Vector(X), LOW  PASS           '                               TFPLOT.31    
     2,'  E-Vector(Y), TOTAL FLUX          '                               TFPLOT.32    
     2,'  E-Vector(Y), HIGH PASS           '                               TFPLOT.33    
     2,'  E-Vector(Y), LOW  PASS           '                               TFPLOT.34    
     3,'  EKE        , TOTAL FLUX          '                               TFPLOT.35    
     3,'  EKE        , HIGH PASS           '                               TFPLOT.36    
     3,'  EKE        , LOW  PASS           '                               TFPLOT.37    
     4,'   UT        , TOTAL FLUX          '                               TFPLOT.38    
     4,'   UT        , HIGH PASS           '                               TFPLOT.39    
     4,'   UT        , LOW  PASS           '                               TFPLOT.40    
     5,'   VT        , TOTAL FLUX          '                               TFPLOT.41    
     5,'   VT        , HIGH PASS           '                               TFPLOT.42    
     5,'   VT        , LOW  PASS           '                               TFPLOT.43    
     :/                                                                    TFPLOT.44    
C                                                                          TFPLOT.45    
      WRITE(NPC4,6000) DAY,KOUNT                                           TFPLOT.46    
 6000 FORMAT(' PROCESSING TRANSIENT FLUXES  AT DAY',F10.2,' KOUNT=',I10)   TFPLOT.47    
C                                                                          TFPLOT.48    
      NLOUT=NL                                                             UTF14.407   
      LTYP=0                                                               UTF14.408   
      IF (LINTP2) THEN                                                     UTF14.409   
         NLOUT=NLPR                                                        UTF14.410   
         LTYP=2                                                            UTF14.411   
      ENDIF                                                                UTF14.412   
C                                                                          UTF14.413   
C     Loops over flux types, 3 per channel (total, high, low pass).        UTF14.414   
C                                                                          UTF14.415   
      DO 40 ITF=1,NTF                                                      TFPLOT.49    
      DO 30 IPASS=1,3                                                      TFPLOT.50    
C                                                                          TFPLOT.51    
         REWIND NCTFO+ITF                                                  TFPLOT.52    
C                                                                          TFPLOT.53    
         DO 20 J=1,JG                                                      TFPLOT.54    
C                                                                          TFPLOT.55    
C        Read required flux into 3D global array.                          TFPLOT.56    
C        Full record reads are used, including excess redundent data.      TFPLOT.57    
C                                                                          TFPLOT.58    
         READ(NCTFO+ITF) (DUMMY,I=1,(IPASS-1)*IGD)                         TFPLOT.59    
     *                  ,(GPV(I,J),I=1,IGD)                                TFPLOT.60    
     *                  ,(DUMMY,I=1,(6-IPASS)*IGD)                         TFPLOT.61    
C                                                                          TFPLOT.62    
C        Zonally average, only if required.                                TFPLOT.63    
C                                                                          TFPLOT.64    
         IF (LPC3) THEN                                                    TFPLOT.65    
            DO 10 IHEM=1,NHEM                                              TFPLOT.66    
            IK=(3-2*IHEM)*J+(JGG+1)*(IHEM-1)                               TFPLOT.67    
            DO 10 L=1,NLOUT                                                UTF14.416   
            IOF=(L-1)*IGC+(IHEM-1)*MGPP                                    TFPLOT.69    
            GAV(IK,L)=RMG*SSUM(MG,GPV(IOF+1,J),1)                          TFPLOT.70    
   10       CONTINUE                                                       TFPLOT.71    
         ENDIF                                                             TFPLOT.72    
C                                                                          TFPLOT.73    
   20    CONTINUE                                                          TFPLOT.74    
C                                                                          TFPLOT.75    
C        Call output routines as required.                                 TFPLOT.76    
C                                                                          TFPLOT.77    
         IFLD=(ITF-1)*3+IPASS                                              TFPLOT.78    
         LPRINT=LOUTP.AND.LTFGR(IFLD)                                      TFPLOT.79    
         LPLOT =LOUTF.AND.LTFPL(IFLD)                                      TFPLOT.80    
         LDUMP =LOUTA.AND.LTFPL(IFLD)                                      TFPLOT.81    
         LOUT=LPRINT.OR.LPLOT.OR.LDUMP                                     TFPLOT.82    
         IF (LOUT.AND.LPC2) THEN                                           TFPLOT.83    
            CALL OUTSUB(GPV,NAME(IFLD),0,NLOUT,1.                          TFPLOT.86    
     :                 ,TFFAC(IFLD),TFINC(IFLD)                            TFPLOT.87    
     :                 ,LTFGR(IFLD),LTFPL(IFLD),IZGTYP,0,0)                TFPLOT.88    
         ENDIF                                                             TFPLOT.89    
C                                                                          TFPLOT.90    
         WRITE(NAME(IFLD)(36:45),'(A)') 'ZONAL MEAN'                       TFPLOT.91    
         LPRINT=LOUTP.AND.LTFGRZ(IFLD)                                     TFPLOT.92    
         LPLOT =LOUTF.AND.LTFPLZ(IFLD)                                     TFPLOT.93    
         LDUMP =LOUTA.AND.LTFPLZ(IFLD)                                     TFPLOT.94    
         LOUT=LPRINT.OR.LPLOT.OR.LDUMP                                     TFPLOT.95    
         IF (LOUT.AND.LPC3) THEN                                           TFPLOT.96    
            CALL XSECT(GAV,NLOUT,NAME(IFLD),NPC3                           UTF14.417   
     :                ,TFFACZ(IFLD),TFINCZ(IFLD)                           UTF14.418   
     :                ,LPRINT,LPLOT,LDUMP,0,LTYP,0)                        UTF14.419   
         ENDIF                                                             TFPLOT.102   
C                                                                          TFPLOT.103   
   30 CONTINUE                                                             TFPLOT.104   
   40 CONTINUE                                                             TFPLOT.105   
C                                                                          TFPLOT.106   
      RETURN                                                               TFPLOT.107   
      END                                                                  TFPLOT.108   
C     ******************************************************************   TFPLOT.109   
*DECK INITAV                                                               INITAV.1     
      SUBROUTINE INITAV(NCI)                                               INITAV.2     
C                                                                          INITAV.3     
C     Time averaging of 3D the global fields.                              INITAV.4     
C     Initialise work files: one record per file, containing all lats.     INITAV.5     
C     Number of levels depends on channel:                                 INITAV.6     
C        Default is NL levels for model-level/isobaric fields.             INITAV.7     
C        Number of fields * levels for isentropic file.                    INITAV.8     
C        Special case for 3 single-level fields.                           INITAV.9     
C        Special case for 1 single-level field.                            INITAV.10    
C                                                                          INITAV.11    
*CALL PARAM1                                                               INITAV.12    
*CALL PARAM2                                                               INITAV.13    
*CALL COMIOC                                                               INITAV.14    
*CALL GRIDP                                                                INITAV.15    
*CALL TIMFLX                                                               INITAV.16    
      INUM=IGD                                                             INITAV.17    
      IF (NCI.EQ.NCTHG)    INUM=NTH*IDTHSF                                 INITAV.18    
      IF (NCI.EQ.NCGP(11)) INUM=3*IGC                                      INITAV.19    
      IF (NCI.EQ.NCGP(12)) INUM=IGC                                        INITAV.20    
      NCTA=NCI+NCTADD                                                      INITAV.21    
C                                                                          INITAV.22    
      DO 10 J=1,JG                                                         INITAV.23    
      DO 10 I=1,INUM                                                       INITAV.24    
      GV1(I,J)=0.                                                          INITAV.25    
   10 CONTINUE                                                             INITAV.26    
C                                                                          INITAV.27    
      REWIND NCTA                                                          INITAV.28    
      WRITE(NCTA) ((GV1(I,J),I=1,INUM),J=1,JG)                             INITAV.29    
C                                                                          INITAV.30    
C     The gridded fields are time-accumulated in loops which include       INITAV.31    
C     the extra two longitudes in I=1,MGPP.                                INITAV.32    
C     NOTE: it is assumed that all the NCGP fields are preset including    INITAV.33    
C     the extra two longitudes, either in the Legendre transforms or in    INITAV.34    
C     the relevant routine called from GRMULT.                             INITAV.35    
C     For the isentropic data, preset the extra two longitudes in the      INITAV.36    
C     instantaneous arrays, to prevent unset values being accumulated.     INITAV.37    
C                                                                          INITAV.38    
      IF (NCI.EQ.NCTHG) THEN                                               INITAV.39    
         DO 20 I=1,IDTHSF                                                  INITAV.40    
         UTHG(I)=0.0                                                       INITAV.41    
         VTHG(I)=0.0                                                       INITAV.42    
         ERTHG(I)=0.0                                                      INITAV.43    
         PTHG(I)=0.0                                                       INITAV.44    
   20 CONTINUE                                                             INITAV.45    
      ENDIF                                                                INITAV.46    
C                                                                          INITAV.47    
      RETURN                                                               INITAV.48    
      END                                                                  INITAV.49    
C     ******************************************************************   INITAV.50    
*DECK TIMV                                                                 TIMV.1     
      SUBROUTINE TIMV(NCI)                                                 TIMV.2     
C                                                                          TIMV.3     
C     Time averaging of the 3D global fields.                              TIMV.4     
C     Accumulate time average 3D field at current analysis time,           TIMV.5     
C     reading/writing a single global record to the time-averaging         TIMV.6     
C     work file, reading JG records from the instantaneous scratch file.   TIMV.7     
C                                                                          TIMV.8     
*CALL PARAM1                                                               TIMV.9     
*CALL PARAM2                                                               TIMV.10    
*CALL COMIOC                                                               TIMV.11    
*CALL TIMFLX                                                               TIMV.12    
      INUM=IGD                                                             TIMV.13    
      IF (NCI.EQ.NCTHG)    INUM=NTH*IDTHSF                                 TIMV.14    
      IF (NCI.EQ.NCGP(11)) INUM=3*IGC                                      TIMV.15    
      IF (NCI.EQ.NCGP(12)) INUM=IGC                                        TIMV.16    
      NCTA=NCI+NCTADD                                                      TIMV.17    
C                                                                          TIMV.18    
      REWIND NCI                                                           TIMV.19    
      REWIND NCTA                                                          TIMV.20    
      READ(NCTA) ((GV1(I,J),I=1,INUM),J=1,JG)                              TIMV.21    
C                                                                          TIMV.22    
      DO 20 J=1,JG                                                         TIMV.23    
      READ(NCI) (G1(I),I=1,INUM)                                           TIMV.24    
      DO 10 I=1,INUM                                                       TIMV.25    
      GV1(I,J)=GV1(I,J)+G1(I)                                              TIMV.26    
   10 CONTINUE                                                             TIMV.27    
   20 CONTINUE                                                             TIMV.28    
C                                                                          TIMV.29    
      REWIND NCI                                                           TIMV.30    
      REWIND NCTA                                                          TIMV.31    
      WRITE(NCTA) ((GV1(I,J),I=1,INUM),J=1,JG)                             TIMV.32    
C                                                                          TIMV.33    
      RETURN                                                               TIMV.34    
      END                                                                  TIMV.35    
C     ******************************************************************   TIMV.36    
*DECK TRANS                                                                TRANS.1     
      SUBROUTINE TRANS(NCI)                                                TRANS.2     
C                                                                          TRANS.3     
C     Time averaging of the 3D global fields.                              TRANS.4     
C     Read global time accumulation, normalise and write in the form       TRANS.5     
C     required by the output routines, one record per latitude (pair),     TRANS.6     
C     on the work file used for the equivalent "instantaneous" field.      TRANS.7     
C                                                                          TRANS.8     
*CALL PARAM1                                                               TRANS.9     
*CALL PARAM2                                                               TRANS.10    
*CALL COMIOC                                                               TRANS.11    
*CALL TIMFLX                                                               TRANS.12    
      INUM=IGD                                                             TRANS.13    
      IF (NCI.EQ.NCTHG)    INUM=NTH*IDTHSF                                 TRANS.14    
      IF (NCI.EQ.NCGP(11)) INUM=3*IGC                                      TRANS.15    
      IF (NCI.EQ.NCGP(12)) INUM=IGC                                        TRANS.16    
      NCTA=NCI+NCTADD                                                      TRANS.17    
C                                                                          TRANS.18    
      REWIND NCTA                                                          TRANS.19    
      REWIND NCI                                                           TRANS.20    
      READ(NCTA) ((GV1(I,J),I=1,INUM),J=1,JG)                              TRANS.21    
C                                                                          TRANS.22    
      DO 20 J=1,JG                                                         TRANS.23    
      DO 10 I=1,INUM                                                       TRANS.24    
      GV1(I,J)=GV1(I,J)/RAV                                                TRANS.25    
   10 CONTINUE                                                             TRANS.26    
      WRITE(NCI) (GV1(I,J),I=1,INUM)                                       TRANS.27    
   20 CONTINUE                                                             TRANS.28    
C                                                                          TRANS.29    
      REWIND NCI                                                           TRANS.30    
      REWIND NCTA                                                          TRANS.31    
C                                                                          TRANS.32    
      RETURN                                                               TRANS.33    
      END                                                                  TRANS.34    
C     ******************************************************************   TRANS.35    
